Hallo,
teste mal ...
Option Explicit
Public Sub Test()
Const FILE_PATH = "C:\Temp\" '<--- anpassen
Dim strFileName As String
Dim objSheet1 As Worksheet
Dim objSheet2 As Worksheet
Dim objWorkbook1 As Workbook
Dim objWorkbook2 As Workbook
Dim aLetzte As Long
On Error GoTo err_exit
Application.ScreenUpdating = False
strFileName = Dir$(FILE_PATH & "*.xls*")
Set objWorkbook2 = ThisWorkbook
Set objSheet2 = objWorkbook2.Worksheets("Tabelle1") '<--- Ziel anpassen
aLetzte = objSheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
Do While strFileName <> ""
Set objWorkbook1 = Workbooks.Open(Filename:= _
FILE_PATH & strFileName, UpdateLinks:=0)
'*** Hier dein Code für das Kopieren ***'
Set objSheet1 = objWorkbook1.Worksheets("Tabelle1") '<--- Quelle anpassen
objSheet2.Cells(aLetzte, 1).Value = objSheet1.Range("B4").Text
objSheet2.Cells(aLetzte, 2).Value = objSheet1.Range("B12").Text
objSheet2.Cells(aLetzte, 3).Value = objSheet1.Range("B13").Text
objSheet2.Cells(aLetzte, 4).Value = objSheet1.Range("B14").Text
objSheet2.Cells(aLetzte, 5).Value = objSheet1.Range("B15").Text
'usw...
aLetzte = aLetzte + 1
objWorkbook1.Close SaveChanges:=False ' nicht Speichern und schließen
strFileName = Dir$()
Loop
err_exit:
Set objWorkbook1 = Nothing
Set objWorkbook2 = Nothing
Set objSheet1 = Nothing
Set objSheet1 = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Gruß Sabina
|