AW: Exeldateien auswerten, zusammenführen
25.05.2006 09:24:18
Franz S
Hallo highman,
ich habe das Makro etwas verändert. Da die Übernahmen von Bereichsnamen und Formeln in der zusammengefassten Datei Probleme machen kann, werden jetzt nur noch die Werte in den Zellen ausgelesen.
Leere Zeilen werden vom Makro wahrschscheinlich nicht erkannt, weil die Zellen in deinen Dateien nicht leer sind, sondern Formeln oder Leerzeichen enthalten.
Der Versuch irgendwie auch die Formate der Zellen in die Zusammenfassung zu übernehmen führte zu exessiven Laufzeiten. Du muß also ggf. die Spalten nochmals formatieren.
Hier der modifizierte Code:
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, Ursprung As Range, Ziel As Range
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
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
Set Ursprung = wks2.Range(wks2.Cells(Reihe, "A"), wks2.Cells(Reihe, "H"))
If Application.WorksheetFunction.CountA(Ursprung) > 0 Then
Set Ziel = wks1.Range(wks1.Cells(Zeile, "A"), wks1.Cells(Zeile, "H"))
Ziel.Value = Ursprung.Value
Zeile = Zeile + 1
End If
Next Reihe
Blatt.Close Savechanges:=False
Dateiname = Dir ' Nächste Datei
Loop
Application.DisplayAlerts = True
Application.StatusBar = False
Application.ScreenUpdating = False
End Sub
Für weitere Fragen bin ich erst ab Montag wieder online.
Gruß
Franz