Suchlauf mit Auflistung
20.03.2019 15:21:40
Al
ich habe folgende Problemstellung. Ich möchte ein Makro per Button steuern, der einen Suchlauf in einem Ordner (mit möglichen Subordnern) erzeugt, bei dem die enthaltenen Dateinamen aufgelistet werden. Ich habe mir auch schon einen Code zusammengestellt, der einen Suchlauf startet, allerdings gibt es folgende Probleme.
1. Ich weiß nicht welche Dateien vorkommen werden in den Ordnern (momentan werden nur PDF, DWG, XLSX aufgelistet), weshalb alle Dateien möglichen berücksichtigt werden sollen.
2. Bei Excelblättern werden diese geöffnet und ggf. mehrfach aufgelistet. Diese sollen aber nur einmal aufgelistet und nicht geöffnet werden.
Hat jemand eine zündende Idee?
Danke für die Mühe.
Gruß
Al
Code
Option Explicit
Dim fso As FileSystemObject
Dim zeileZ As Long
Dim wsZ As Worksheet 'Zielblatt
Sub DatenAuslesen_mit_Unterverz()
' ThisWorkbook.SaveCopyAs (ThisWorkbook.Path & "\" & _
' Replace(ThisWorkbook.Name, ".xls", "_backup.xls")) 'backup erstellen _
bevor Makro ausgefuehrt wird
Dim ergebnis As Long
Dim fd As FileDialog
Dim fol As Folder
Dim letzteZeileZ As Long
Dim pfad As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'oeffnet ein Dialogfeld _
(Auswahlfenster)
fd.InitialFileName = ThisWorkbook.Path & "\" 'Starte das Dialogfeld _
im Verzeichnes dieses Blattes
ergebnis = fd.Show
If ergebnis = 0 Then 'Vorgang bei Abbruch
' MsgBox Prompt:="Abbruch durch den Benutzer"
Exit Sub
End If
pfad = fd.SelectedItems(1)
Set fso = New FileSystemObject 'Abbruf/?nderung von _
Infos aus Ordnern/Dateien
Set fol = fso.GetFolder(pfad)
Set wsZ = ThisWorkbook.Worksheets("Daten")
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "A").End(xlUp).Row
zeileZ = letzteZeileZ + 1 'Setze Daten _
nacheinander ein
Folder_abarbeiten Verzeichnis:=fol
Set fso = Nothing
End Sub
Sub Folder_abarbeiten(Verzeichnis As Folder)
Dim fil As File
Dim fol As Folder
Dim pos As Long
Dim suchErgebnis As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim zeichNr As String
Dim zeileStahlgewicht As Long
For Each fil In Verzeichnis.Files
If Left(fil.Name, 1) = "~" Then '?berspringen bei tem. _
Datei
ElseIf LCase(ThisWorkbook.Name) = LCase(fil.Name) Then '?berspringen der _
Verknuepfung
ElseIf fil.Name Like "*.xls*" Then 'Gueltigkeit
pos = InStrRev(fil.Name, ".") 'Zeichnungsnr aus _
Dateiname (starte von links)
zeichNr = Left$(fil.Name, pos - 1) 'nur Exceldatei mit _
Namen 10 Then
Set wb = Workbooks.Open(Filename:=fil.Path, UpdateLinks:=False)
For Each ws In wb.Worksheets
Set suchErgebnis = ws.Cells.Find(What:="Stahlgewicht") 'wegen der verbundenen _
Zellen in Spalte D wird in Cells gesucht
If Not suchErgebnis Is Nothing Then
If suchErgebnis.Column = 4 Then
zeileStahlgewicht = suchErgebnis.Row 'Ausgabe von
wsZ.Cells(zeileZ, "A") = wb.Name 'Zeichnungsnummer mit _
Endung
zeileZ = zeileZ + 1
End If
End If
Next ws 'naechstes Tab _
durchsuchen
wb.Close savechanges:=False
End If
ElseIf fil.Name Like "*.pdf*" Then 'Gueltigkeit
pos = InStrRev(fil.Name, ".") 'Zeichnungsnr aus _
Dateiname (starte von links)
zeichNr = Left$(fil.Name, pos - 1) 'nur Exceldatei mit _
Namen 10 Then
Set wb = Workbooks.Open(Filename:=fil.Path, UpdateLinks:=False)
For Each ws In wb.Worksheets
wsZ.Cells(zeileZ, "A") = wb.Name 'Berechnungsnummer mit _
Endung
zeileZ = zeileZ + 1
Next ws 'naechstes Tab _
durchsuchen
wb.Close savechanges:=False
End If
ElseIf fil.Name Like "*.dwg*" Then 'Gueltigkeit
pos = InStrRev(fil.Name, ".") 'Zeichnungsnr aus _
Dateiname (starte von links)
zeichNr = Left$(fil.Name, pos - 1) 'nur Exceldatei mit _
Namen 10 Then
Set wb = Workbooks.Open(Filename:=fil.Path, UpdateLinks:=False)
For Each ws In wb.Worksheets
wsZ.Cells(zeileZ, "A") = wb.Name 'Zeichnungsnummer mit _
Endung
zeileZ = zeileZ + 1
Next ws 'naechstes Tab _
durchsuchen
wb.Close savechanges:=False
End If
End If
Next fil 'naechste Datei _
durchsuchen
For Each fol In Verzeichnis.SubFolders
Folder_abarbeiten Verzeichnis:=fol
Next fol 'naechstes Verzeichnis _
durchsuchen
End Sub