AW: Datenimport aus mehreren Arbeitsmappe
30.09.2020 14:59:05
Nepumuk
Hallo Firat,
teste mal:
Option Explicit
Public Sub Import_Dispatch_customer()
Dim strFolder As String, astrFolders() As String
Dim strFileName As String
Dim ialngFolders As Long, lngRow As Long
Dim objWorksheet As Worksheet, objWorkbook As Workbook
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
lngRow = 1
strFolder = Environ$("USERPROFILE") & "\Desktop\Customer\"
astrFolders = GetFolders(strFolder)
Set objWorksheet = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Sheets(1))
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFileName = Dir$(astrFolders(ialngFolders) & "Dispatch_customer_*.xls*")
Do Until strFileName = vbNullString
Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strFileName)
With objWorkbook.Worksheets(1)
Call .Range(.Cells(3, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 20)).Copy( _
Destination:=objWorksheet.Cells(lngRow, 1))
End With
Call objWorkbook.Close(SaveChanges:=False)
With objWorksheet
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
strFileName = Dir$
Loop
Next
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
Redim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder <> "." And strFolder <> ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
Redim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function
Gruß
Nepumuk