Hi Muri,
Hier mal ein Code, der
1) alle Exceldateien im Ordner oder Unterordner durchsucht
2) diese Öffnet
3) den zusammenhängenden Bereich ab A1 kopiert
4) in einem zuvor definierten Mastersheet kopiert bzw unten anhängt
Hinweis:
Es sind diverse Bedingungen in dem Code deaktiviert, aber grundsätzlich macht er das, was Du versuchst umzusetzen.
Wenn fragen dazu sind, bezüglich einer Anpassung an Deine Datei, kommr hier rüber mit Beispieldatei:
https://www.ms-office-forum.net/forum/index.php?referrerid=81823
Option Explicit
Dim fso As Scripting.FileSystemObject
Dim wkbQuelle As Workbook
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim m_sFolder As String
Const m_sPath As String = "ZU_DURCHSUCHENDER_PFAD"
Sub main()
'
Set wksZiel = ThisWorkbook.Worksheets(1)
'
Call ImportEachFile(m_sPath)
End Sub
Sub ImportEachFile(m_sFolder As String)
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oSubFolder As Scripting.Folder
'
Set fso = New Scripting.FileSystemObject
For Each oSubFolder In fso.GetFolder(m_sFolder).SubFolders
'go recursive
Call ImportEachFile(oSubFolder.Name)
Next
'
For Each oFile In fso.GetFolder(m_sFolder).Files
'If Len(oFile.Name) = 11 Then
'Open File and Import Currentregion + workdate
Call FillOutMasterWorksheet(oFile.Path)
'End If
Next
End Sub
Function getCopyCurrentRegion(wks As Worksheet) As Variant
'Dim wks As Worksheet
Dim arr()
Dim y As Long, x As Long
'
arr = wks.Range("A1").CurrentRegion
'ReDim Preserve arr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)
'For y = 1 To UBound(arr, 1) Step 1
' arr(y, UBound(arr, 2)) = Mid(wks.Name, 1, 2) & "." & Mid(wks.Name, 3, 2) & "." & Mid(wks.Name, 5, 2)
'Next y
'
getCopyCurrentRegion = arr
End Function
Sub FillOutMasterWorksheet(sWorkbook As String)
Dim arr() As Variant
'
Set wkbQuelle = Workbooks.Open(sWorkbook, False)
With wkbQuelle
Set wksQuelle = .Worksheets(1)
arr = getCopyCurrentRegion(wksQuelle)
.Close True
End With
'
With wksZiel
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End With
'
Erase arr
Set wksQuelle = Nothing
Set wkbQuelle = Nothing
End Sub
|