Hallo liebe Profis,
ich hoffe jemand kann mir bei einem kniffeligen Problem helfen.
Ich muss Daten aus mehreren Excel Dateien und mehreren Tabellenblättern zusammenstellen in einer Excel Datei auf einem Blatt.
Das Schema der einzelnen Blätter und Dateien ist immer gleich, auch die Namen der Excel Dateien werden nicht verändert.
Es funktioniert bereits soweit, dass ich aus einer Excel Datei die Abfrage starten kann, allerdings nur für diese Datei eben. Es werden dann bestimmte Felder aus allen Arbeitsblättern abgefragt deren Name mindestens 4 stellig ist.
Die Daten werden dann in eine neue Datei geschrieben.
Folgender Code:
Private Sub Uebersicht_Click()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iSINW As Integer, iRow As Integer
Dim rZelle As Range, rBereich As Range
Dim sRange As String
sRange = "B2,B3,B7,B36,B27,D27,B28,D28,B29,D29,B30,D30,B17,D17,B18,D18,B19,D19"
iRow = 1
iCol = 1
iSINW = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set WS2 = Workbooks.Add.ActiveSheet
Application.SheetsInNewWorkbook = iSINW
Application.ScreenUpdating = False
With WS2
For Each WS1 In ThisWorkbook.Worksheets
If Len(WS1.Name) > 3 Then
Set rBereich = WS1.Range(sRange)
.Cells(iRow, iCol) = WS1.Name
For Each rZelle In rBereich
iCol = iCol + 1
With .Cells(iRow, iCol)
.Value = rZelle.Value
.NumberFormat = rZelle.NumberFormat
End With
Next
Set rZelle = Nothing
iRow = iRow + 1
iCol = 1
End If
Next WS1
.Name = "Übersicht"
End With
Application.ScreenUpdating = True
MsgBox "Übersicht wurde fertig erstellt.", vbOKOnly, "Info"
Exit Sub
Fehler:
MsgBox "Übersicht konnte nicht vollständig erstellt werden.", vbOKOnly, "Achtung"
Application.ScreenUpdating = True
End Sub
In diesem Code fehlt mir noch, dass die Spalten anschließend die optimale Breite haben. Wenn ich das so per AutoFit mache, dann bekommen die Spalten in der Datei wo das Makro steht die optimale Breite, jedoch nicht die in der erzeugten Datei. Aber das ist nur sekundär.
Wichtig ist, dass nicht nur dieses Workbook abgefragt wird
For Each WS1 In ThisWorkbook.Worksheets
If Len(WS1.Name) > 3 Then
sondern auch weitere namentlich benannte im selben ordner.
Beispielsweise
Filiale1000.xls
Filiale2000.xls
Filiale3000.xls
Ich hoffe ich habe mein Problem so gut es geht beschrieben und mir kann jemand helfen.
Lieben Gruß
Sascha
|