Daten auslesen
11.03.2015 09:39:17
Kilian
mein Ziel ist es, aus verschiedenen Excel-Files Immer die selben Daten auszulesen. Hierfür habe ich mir, über verschiedene Internet Beiträge, ein Makro zusammengeschustert.
Es wird ein Ordner ausgewählt, und alle Files in diesem Ordner werden nach einander geöffnet und geschlossen. In der ersten Stufe habe ich nur werte aus Sheet(1) genommen. Das hat wunderbar funktioniert. Jetzt kommt aber hinzu, dass jede Datei unterschiedlich viele Sheets enthält und ich benötige Werte aus allen Sheets, die mit "P0" beginnen.
Somit habe ich in den Do While - Loop noch eine For Each - Schleife gebaut, um jede einzelne File nach worksheets zu durchsuchen, die mit "P0" beginnen.
Leider öffnet das Makro jetzt nur noch alle Files, ohne Werte in die Konsolidierungsdatei einzufügen. Nachdem die letzte Datei geöffnet wurde, hört das Makro auf.
Ich nehme an, das über ws.name = "P0" gesuchte worksheet (ws) wird nicht richtig deklariert oder so?
Vielen Dank für eure Hilfe, bereits im Voraus,
viele Grüße, Kilian
Sub Daten_kopieren()
Dim AppShell As Object
Dim BrowseDir As Variant
Dim strVZ As String
Dim Dateiname As String
Dim irow As Long
Dim wb As Object, wb2 As Object
Dim sDatei As String
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set wb = ActiveWorkbook
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
strVZ = BrowseDir.items().Item().Path
If strVZ = "" Then Exit Sub
MsgBox strVZ
On Error GoTo 0
Dateiname = Dir(strVZ & "\*.xls*")
Do While Dateiname ""
Set wb2 = Workbooks.Open(Filename:=strVZ & "\" & Dateiname)
wb2.Activate
For Each ws In wb2.Worksheets
If ws.Name = "P0" Then
irow = wb.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0).Row
wb.Sheets(1).Cells(irow, 1) = Dateiname
wb.Sheets(1).Cells(irow, 2).Value = _
wb2.ws.Range("K50").Value
wb.Sheets(1).Cells(irow, 3).Value = _
wb2.ws.Range("K51").Value
wb.Sheets(1).Cells(irow, 4).Value = _
wb2.ws.Range("K52").Value
wb.Sheets(1).Cells(irow, 5).Value = _
wb2.ws.Range("K53").Value
wb.Sheets(1).Cells(irow, 6).Value = _
wb2.ws.Range("K48").Value
wb2.Close False
End If
Next ws
Dateiname = Dir()
Set wb2 = Nothing
Loop
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub