Samle flere tabeller til én tabel

Vil det sige at strukturen er ens - forskellen er antal rækker?

Er tabeller i samme regnearksfil?

Hvordan identificeres de ark, der skal samles.

VBA vil kunne gøre dette.

Ja, strukturen er ens og antallet af rækker er forskelligt.
Der ligger 1 tabel i hvert ark - alle ark er samlet i samme fil.
Alle ark har et navn.

Ok - vender tilbage..

Opret et nyt ark - kald det "Samling" (er anvendt i koden) - kopier nedenstående VBA-kode ind under dette ark. Start koden med Alt+F8 / marker SamlingAfArk / Afspil makro

Const samleArkNavn = "Samling"                      '<---- evt. justeres

Dim antalArk As Integer, antalRæk As Integer, antalKol As Integer, arkNavn As String

Dim rækNr As Integer, arkNr As Integer, r1 As Range, a1 As Worksheet, startRæk As Integer

Public Sub samlingAfArk()
    arkNr = 0
    rækNr = 1
   
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> samleArkNavn Then
            ark.Activate
            antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
            antalKol = ActiveCell.SpecialCells(xlLastCell).Column
            arkNavn = ark.Name
           
            Set a1 = ActiveWorkbook.ActiveSheet
           
            If arkNr = 0 Then
                startRæk = 1
            Else
                startRæk = 2
            End If
           
            Set r1 = a1.Range(a1.Cells(startRæk, 1), a1.Cells(antalRæk, antalKol))
           
            r1.Copy Destination:=Worksheets(samleArkNavn).Range("A" & rækNr)
            rækNr = rækNr + antalRæk
            arkNr = arkNr + 1
        End If
    Next
End Sub

Det virker et stykke hen ad vejen. Der kommer en boks på skærmen med beskeden "Overflow" og så går den i stå inden alle ark er overført.

I samle-arket kommer der en blank linje efter hver kopieret ark. Det er selvfølgelig ret nemt at fjerne efterfølgende, men nemmere hvis det ikke skete.

Kan man slutte af med at give den nye samle-tabel et navn?

Hvor mange ark er der tale - hvor mange kolonner og ca. rækker pr. ark?

Der kan være tale om en blank række i de enkelte ark. Der testes ikke på denne i VBA-koden

Du kan selv justere navnet på samlearket, når - se i VBA-koden
Const samleArkNavn = "Samling"      '<---- evt. justeres

Højreklik på arket / vis programkode / juster navnet og gem VBA-koden

Nu testes der på om sidste række er blank i kolonne A
Endvidere udskrives rækkenummer på samlearket løbende i statuslinjen nederst til venstre.


Rem Version 2
Const samleArkNavn = "Samling"                      '<---- evt. justeres

Dim antalArk As Integer, antalRæk As Integer, antalKol As Integer, arkNavn As String

Dim rækNr As Integer, arkNr As Integer, r1 As Range, a1 As Worksheet, startRæk As Integer
Public Sub samlingAfArk()
    arkNr = 0
    rækNr = 1
   
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> samleArkNavn Then
            ark.Activate
            antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
            antalKol = ActiveCell.SpecialCells(xlLastCell).Column
            arkNavn = ark.Name
           
            Set a1 = ActiveWorkbook.ActiveSheet
           
            If arkNr = 0 Then
                startRæk = 1
            Else
                startRæk = 2
            End If
           
Rem test om sidste række er blank
            If a1.Range("A" & antalRæk) = "" Then
                antalRæk = antalRæk - 1
            End If
           
            Set r1 = a1.Range(a1.Cells(startRæk, 1), a1.Cells(antalRæk, antalKol))
           
            r1.Copy Destination:=Worksheets(samleArkNavn).Range("A" & rækNr)
            rækNr = rækNr + antalRæk
            arkNr = arkNr + 1
           
            Application.StatusBar = "Sidste række: " & rækNr
        End If
    Next
End Sub

Har nu korrigeret datatyper vedr. rækkenr - det kan meget vel være det, der er skyld i overflow.

Rem Version 3
Const samleArkNavn = "Samling"                      '<---- evt. justeres

Dim antalArk As Integer, antalRæk As Long, antalKol As Integer, arkNavn As String

Dim rækNr As Long, arkNr As Integer, r1 As Range, a1 As Worksheet, startRæk As Integer
Public Sub samlingAfArk()
    arkNr = 0
    rækNr = 1
   
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> samleArkNavn Then
            ark.Activate
            antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
            antalKol = ActiveCell.SpecialCells(xlLastCell).Column
            arkNavn = ark.Name
           
            Set a1 = ActiveWorkbook.ActiveSheet
           
            If arkNr = 0 Then
                startRæk = 1
            Else
                startRæk = 2
            End If
           
Rem test om sidste række er blank
            If a1.Range("A" & antalRæk) = "" Then
                antalRæk = antalRæk - 1
            End If
           
            Set r1 = a1.Range(a1.Cells(startRæk, 1), a1.Cells(antalRæk, antalKol))
           
            r1.Copy Destination:=Worksheets(samleArkNavn).Range("A" & rækNr)
            rækNr = rækNr + antalRæk
            arkNr = arkNr + 1
           
            Application.StatusBar = "Sidste række: " & rækNr
        End If
    Next
End Sub

Data >> Konsolidering

Hej supertekst

Nu kommer alle linjer med over i samle-arket, så problemet med overflow er løst.
Den tomme linje bliver stadig dannet hver gang der er blevet kopieret et dataområde.

(beklager i øvrigt at jeg ikke har svaret noget før - jeg blev sat på en anden opgaven i en periode)

Mvh. Christina

Hej chrisengholm

Er det sådan, at der er en tom række efter den sidst udfyldte på de ark, der samles?

Ok med "ventetiden"

Mvh
Supertekst

Hvis ja - så prøv denne version:

Rem Version 4
Const samleArkNavn = "Samling"                      '<---- evt. justeres

Dim antalArk As Integer, antalRæk As Long, antalKol As Integer, arkNavn As String

Dim rækNr As Long, arkNr As Integer, r1 As Range, a1 As Worksheet, startRæk As Integer
Public Sub samlingAfArk()
    arkNr = 0
    rækNr = 1
   
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> samleArkNavn Then
            ark.Activate
            antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
            antalKol = ActiveCell.SpecialCells(xlLastCell).Column
            arkNavn = ark.Name
           
            Set a1 = ActiveWorkbook.ActiveSheet
           
            If arkNr = 0 Then
                startRæk = 1
            Else
                startRæk = 2
            End If
           
Rem test om sidste række er blank
            If Trim(a1.Range("A" & antalRæk)) = "" Then
                antalRæk = antalRæk - 1
            End If
           
            Set r1 = a1.Range(a1.Cells(startRæk, 1), a1.Cells(antalRæk, antalKol))
           
            r1.Copy Destination:=Worksheets(samleArkNavn).Range("A" & rækNr)
            rækNr = rækNr + antalRæk
            arkNr = arkNr + 1
           
            Application.StatusBar = "Sidste række: " & rækNr
        End If
    Next
End Sub

Tak for hjælpen.
Vil du lægge et svar :-)

Selv tak