Anzeige

VBA Code für mehrere Excel Datenblätter zusammenzufügen?


#1
Hallo Zusammen

Ich habe ein Problem mit VBA. Ich will ein Makro programmieren, das aus einer Arbeitsmappe verschiedene Tabellenblätter in einem Tabellenblatt zusammenfasst. Dabei sollen aber nicht alle Daten aus den Tabellenblätter in das Tabellenblatt kopiert werden sondern nur ausgewählte. Für ein Tabellenblatt habe ich die den VBA Code gefunden:

Sub Masterfile()

Dim wksDM As Worksheet
Dim wks1612 As Worksheet
Dim wks1706 As Worksheet
Dim wks1707 As Worksheet
Dim wks1708 As Worksheet
Dim wks1710 As Worksheet

Set wksDM = ActiveWorkbook.Worksheets("Debitoren Makro")
Set wks1612 = ActiveWorkbook.Worksheets("1612")
Set wks1706 = ActiveWorkbook.Worksheets("1706")
Set wks1707 = ActiveWorkbook.Worksheets("1707")
Set wks1708 = ActiveWorkbook.Worksheets("1708")
Set wks1710 = ActiveWorkbook.Worksheets("1710")
lngZeileDM = 2
For lngZeile1612 = 2 To 45

If Not wks1612.Cells(lngZeile1612, 2).Text = "" Then
wksDM.Cells(lngZeileDM, 1).Value = wks1612.Cells(lngZeile1612, 2).Value
wksDM.Cells(lngZeileDM, 2).Value = wks1612.Cells(lngZeile1612, 3).Value
wksDM.Cells(lngZeileDM, 3).Value = wks1612.Cells(lngZeile1612, 4).Value
wksDM.Cells(lngZeileDM, 4).Value = wks1612.Cells(lngZeile1612, 5).Value
wksDM.Cells(lngZeileDM, 5).Value = wks1612.Cells(lngZeile1612, 6).Value
wksDM.Cells(lngZeileDM, 6).Value = wks1612.Cells(lngZeile1612, 7).Value
wksDM.Cells(lngZeileDM, 7).Value = wks1612.Cells(lngZeile1612, 8).Value
lngZeileDM = lngZeile1612 + 1
End If
Next

End Sub

Nun funktioniert der Code aber nur für das wks1612. Wie schaffe ich es, dass für die Tabellenblätter 1706, 1707, 1708 und 1710 sowie weiter Tabellenblätter die noch dazukommen funktioniert. Das heisst es sollen immer die gleichen Werte "If Not wks....Cells(IngZeile....,2) = ""Then" in das Tabellenblatt DM kopiert werden.

Besten Dank für Eure Hilfe.

LG

David
 

Yaslaw

n/a
Moderator
#2
1) Nutze die Möglichkeiten von Excel. Also Daten filtern und dann kopieren
2) Schreibe den Kopiervorgang in eine eigene Sub. Diese kann man dann pro Quelle aufrufen

Visual Basic:
Public Sub mergeSheets()

    addWs Worksheets("1612"), Worksheets("sheet1")
    addWs Worksheets("1706"), Worksheets("sheet1")
    
    Worksheets("sheet1").Select
End Sub

Private Sub addWs(ByRef iSourceWs As Worksheet, ByRef iTargetWs As Worksheet)
    Dim lastSourceRow As Long
    Dim lastTargetRow As Long
    
    'Letzte Zeile ermitteln
    lastSourceRow = xlsGetLastRow(iSourceWs)
    'Filter setzen (Spalte 2 darf nicht leer sein)
    iSourceWs.UsedRange.AutoFilter Field:=2, Criteria1:="<>"
    'gefiltete Daten kopieren (Ohne Header)
    iSourceWs.Range("2:" & lastSourceRow).Copy
    'Letzte Zeile am Ziel ermitteln
    lastTargetRow = xlsGetLastRow(iTargetWs)
    'und eine Zeile darunter einfügen einfügen
    iTargetWs.Paste iTargetWs.Range("A" & lastTargetRow + 1)
    'Filter entfernen
    iSourceWs.ShowAllData
End Sub

'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function
 

Yaslaw

n/a
Moderator
#4
Ist bereits berücksichtigt. Die Endzeile wird bei jedem Sheet neu ermittelt
Visual Basic:
    'Letzte Zeile ermitteln
    lastSourceRow = xlsGetLastRow(iSourceWs)
 
Anzeige

Neue Beiträge

Anzeige