habe weit über 500 Arbeitsmappen in einem Ordner und würde gerne, nach dem in der ComboBox ausgewählten Suchkriterium, in dem Ordner gespeicherten Arbeitsmappen durchsuchen. Aus den Dateien mit dem gefundenen Suchkriterium soll der Bereich F6:M10 in die aktive Tabelle ab der Ziele A5 untereinander kopieren werden.
Das Suchkriterium steht in allen Arbeitsmappen in der Tabelle "Rohdaten" in Zelle C6.
Ich habe bereits in der Recherche gesucht und das nachfolgende Makro gefunden.
Leider, mit der ComboBox und Suchkriterium auswählen, haperte es bei mir.
'StandardModule: basMain
Sub DatenImport()
Dim arr As Variant
Dim iCounter As Integer, iRow As Integer
Dim sPath As String
Application.ScreenUpdating = False
sPath = GetDirectory( _
"Bitte Pfad der Quelldateien auswählen:")
If sPath = "" Then Exit Sub
arr = FileArray(sPath, "*.xls")
iRow = 5
For iCounter = 1 To UBound(arr)
Workbooks.Open sPath & "\" & arr(iCounter)
Range("F6:M10").Copy _
ThisWorkbook.ActiveSheet.Cells(iRow, 1)
ActiveWorkbook.Close savechanges:=False
iRow = iRow + 10
Next iCounter
Application.ScreenUpdating = True
End Sub
''Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1) "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function
Würde mich sehr freuen, wenn jemand helfen könnte. Danke schon jetzt.
Grüße