Daten zusammenführen - falsches Blatt
31.01.2007 15:37:39
Lilianna
ich habe aus dem Forum ein Makro genommen, das ich für meine Anwendung brauche. (zusammenführen von verschiedenen Daten aus verschiedenen Files, die sich alle in einem Ordner befinden).
Das Makro funktioniert einwandfrei, aber es werden die Daten vom falschen Blatt rauskopiert. das Makro nimmt automatisch das erste Blatt, doch ich bracuhe der entsprechende Bereich vom Blatt "event". Wo muss ich das beim entsprechenden anpassen?
Vielen Dank an alle, die Geduld mit Anfängern haben...
Sub DatenZusammenfuegen()
' Übernahme von Daten aus mehreren Blättern auf ein Tabellenblatt
Dim Blatt As Workbook, wb1 As Workbook, wks1 As Worksheet, Steuerung As Worksheet
Dim Pfad As String, Dateiname As String, wks2 As Worksheet, Reihe As Long
Dim Zeile1 As Long, Zeile As Long, Spalte As Integer
Set Steuerung = ThisWorkbook.Sheets("Tabelle1")
'Neue Arbeitsmappe anlegen
Set wb1 = Workbooks.Add
'Überzählige Blätter löschen
Application.DisplayAlerts = False
For I = wb1.Sheets.Count To 2 Step -1
wb1.Sheets(I).Delete
Next
Application.DisplayAlerts = True
Pfad = Steuerung.Range("B8").Value ' Verzeichnis der Blätter
Zeile1 = 2 '1. Zeile ab der Daten in neue Tabelle eingefügt werden sollen
Zeile = Zeile1
Set wks1 = wb1.Sheets(1)
Application.ScreenUpdating = False
Dateiname = Dir(Pfad & "\*.XLS")
Do Until Dateiname = ""
Set Blatt = Workbooks.Open(Pfad & "\" & Dateiname)
Application.StatusBar = "Datei " & Blatt.Name & " wird eingelesen"
' Daten im Blatt kopieren und in neues Blatt einfügen
Set wks2 = Blatt.Sheets(1)
If Zeile = Zeile1 Then ' Spaltenbreiten formatieren bevor Daten aus 1. Blatt kopiert werden
For Spalte = 1 To 8 'Spalten A bis H
wks1.Cells(1, Spalte).ColumnWidth = wks2.Cells(1, Spalte).ColumnWidth
Next
End If
For Reihe = 16 To 35
If Application.WorksheetFunction.CountA(wks2.Range(wks2.Cells(Reihe, "A"), wks2.Cells(Reihe, "H"))) > 0 Then
wks2.Range(wks2.Cells(Reihe, "A"), wks2.Cells(Reihe, "H")).Copy wks1.Cells(Zeile, 1)
Zeile = Zeile + 1
End If
Next Reihe
Blatt.Close Savechanges:=False
Dateiname = Dir ' Nächste Datei
Loop
Application.StatusBar = False
Application.ScreenUpdating = False
End Sub