Dateien aus einem Ordner in Masterdatei kopieren

[SimonVBA]

Hallo, 

die Werte werden nun kopiert, allerdings in dem Bereich 30321 bis 38900, zwischen den einzelnen Datensätzen sind viele Leerzeilen. 

Hier der gesamte Code, welchen ich verwende, meiner Meinung nach ist die Zielzeile mit 7 angegeben, weiß einer weiter?

Code:

Sub Uebertrag()

    Dim WbM As Workbook, TbM As Worksheet
    Dim WbX As Workbook, TbX As Worksheet, TaBname As String, TB3 As Worksheet
    Dim LR As Long, RR As Long, Zeile As Long, Z1 As Integer
    Dim PfadQ As String
    Dim Ext As String, Datei As String, Anz As Long, D1 As Integer, D2 As Integer
   
    Application.ScreenUpdating = False
   
    Set WbM = ThisWorkbook
    Set TbM = WbM.Sheets("Report_Sales") 'das Zielblatt
    TaBname = "Feedback" 'Name des Quellblattes
   
    Set TB3 = WbM.Sheets("Merker") ' Blatt um die gelesenen Tabellen zu merken
   
    Z1 = 7 'Kopieren ab
    Ext = "*.xl*"
    Zeile = 7 'Beispiel erste Zielzeile
   
   
    PfadQ = TbM.Range("G1") & "\" 'Quellpfad
    PfadQ = Replace(PfadQ, "\\", "\") ' ggf doppelte \ am Ende antfernen
   
    If Dir(PfadQ, vbDirectory) = "" Then
        MsgBox "Quellpfad existiert nicht"
        Exit Sub
    End If
   
   
    Datei = Dir(PfadQ & Ext)
    Do While Len(Datei) > 0
   
        D1 = D1 + 1 'zählen vorgefunden
   
        If WorksheetFunction.CountIf(TB3.Columns(1), Datei) = 0 Then
            'prüfen, ob schon bearbeitet
            D2 = D2 + 1 'zählen neu geladen
           
            LR = TB3.Cells(TB3.Rows.Count, "A").End(xlUp).Row + 1 'erste freie Zeile der Spalte
            TB3.Cells(LR, 1) = Datei 'Datei merken
       
            Set WbX = Workbooks.Open(Filename:=PfadQ & Datei)
            Set TbX = WbX.Sheets(TaBname)
            TbX.Unprotect Password:="PT"
           
            RR = TbX.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
            Zeile = WorksheetFunction.Max(Zeile, TbM.Cells.SpecialCells(xlCellTypeLastCell).Row + 1)
            Anz = RR - Z1 + 1 'Anzahl der zu kopierenden Zeilen
           
            TbX.Cells(Z1, 1).Resize(Anz, 26).Copy TbM.Cells(Zeile, 1)
       
            WbX.Close False 'schließen ohne speichern
        End If
       
        Datei = Dir() ' nächste Datei
    Loop
   
    MsgBox D1 & ":  Dateien vorgefunden" & vbLf & vbLf & _
           D2 & ":  davon neu verarbeitet"
           
End Sub

Vielen Dank und Grüße
Simon

[UweD]

Hallo nochmal

Ohne Dateien keine Weitere Aussage von mir.
Alles Andere ist Raten.

LG UweD

[schauan]

Hallöchen,

meiner Meinung nach ist die Zielzeile mit 7 angegeben

ja, aber dann kommt
Zeile = WorksheetFunction.Max(Zeile, TbM.Cells.SpecialCells(xlCellTypeLastCell).Row + 1)