Datenabgleich 1000+ *.xlsx files

Hallo zusammen,
durch einen Arbeitskollegen habe ich den Tipp bekommen in diesem Forum Hilfe zu suchen da unsere VBA Profis nicht weiter wissen....
Folgende Aufgabenstellung:
In einem Ordner in unserem Netzwerklaufwerk ist für jeden Artikel ein Ordner angelegt. Dieser kann 1 oder mehrere Unterordner haben. In diesem/n Unterordner/n ist ein Festgelegtes Benennungsschema vorhanden (wenigstens dort).
Ich muss jeden der Unterordner nach *.xlsx Dateien durchsuchen. Falls vorhanden, öffnen und kontrollieren ob in Zelle "II" ein bestimmter Text steht.
Falls ja: Text aus Zelle C6 und C9 (Oder Ordnername) nebeneinander in ein Sheet schreiben mit der Bemerkung "Vorhanden"
Falls Nein: Ordnernamen des ersten Unterordners in ein Sheet schreiben und die Bemerkung "Nicht vorhanden" dazuschreiben.
Warum der Ordnername? Produktnummern sind ausschließlich numerisch und treffen, zum glück, immer zu (in Bezug auf Richtigkeit der Daten) weshalb der Ordnername zur Identifikation genutzt werden kann.
Beispiel:
...\Produkte\1234567\Lieferant1\PPAP\*.xlsx (die die ich benötige)
...\Produkte\1234567\Lieferant2\PPAP\ (LEER)
...\Produkte\7654321\Lieferant1\PPAP\*.PDF
...\Produkte\7654321\Lieferant1\PPAP\*.xlsx (eine andere Datei)
Ich hoffe ich konnte das verständlich erklären!
z.Z. arbeite ich mit FSO und einer sich selbst aufrufenden Funktion.

Sub ListFolders(SourceFolderName As String)
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim r As Long
Dim strfile As String
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim thiswb As Workbook
Set ThisSheet = Workbooks("WorkInstruction Masscheck.xlsm").Worksheets("Tabelle1")
Set thiswb = Workbooks("WorkInstruction Masscheck.xlsm")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error Resume Next
iColumn = iColumn + 1
thiswb.ThisSheet.Cells.Offset(1).Select
With Cells(ActiveCell.Row, iColumn)
If IsNumeric(SourceFolder.Name) = True Then
.Formula = SourceFolder.Name
End If
.Font.ColorIndex = 11
.Font.Bold = True
.Select
End With
strfile = Dir(SourceFolder.Path & "\*.*")
If strfile  vbNullString Then
thiswb.ThisSheet.ActiveCell.Offset(0, 1).Select
Do While strfile  vbNullString
thiswb.ThisSheet.ActiveCell.Offset(1).Select
If Right(strfile, 4) = "xlsx" Then
wb = Workbooks.Open(SourceFolder.Path & "\" & strfile, ReadOnly:=True)
thiswb.ThisSheet.ActiveCell.Value = wb.Worksheets(1).Range("I1")
Workbooks(strfile).Close
End If
'ThisSheet.ActiveCell.Value = strfile
strfile = Dir
'Workbooks(strfile).Close
Loop
thiswb.ThisSheet.ActiveCell.Offset(0, -1).Select
End If
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
iColumn = iColumn - 1
Next SubFolder
Set SubFolder = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub

Sub testfunc()"...\Produkte\"
End Sub

z.Z. befinden sich einige patchworks im Code daher etwas unsauber und nicht mehr ganz rein zielführend. Aber der Grundsatz sollte erkennbar sein.
Für Ideen zu anderen Vorgehensweisen bin ich ebenfalls sehr dankbar. (Die Runtime beträgt z. Z. 7h+).

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Declare Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As _ String) As Long Public Function F_ASC_ANS(ByVal Text As String) As String OemToCharA Text, Text F_ASC_ANS = Text End Function Sub F_en() Dim WB As Workbook lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 Application.ScreenUpdating = False '########################################################################## Directory anpassen # _ fn = Split(F_ASC_ANS(CreateObject("wscript.shell").exec("cmd /c Dir ""C:\temp\*.xlsx"" /b/s" _ ).stdout.readall), vbCrLf) For i = 0 To UBound(fn) - 1 Application.StatusBar = i & ": " & fn(i) Pa = Split(fn(i), "\") ThisWorkbook.Sheets(1).Cells(lr, 1) = Pa(UBound(Pa) - 1) 'Name des Directories If InStr(1, fn(i), "David") > 0 Then 'nur zum Testen Set WB = GetObject(fn(i)) If WB.Sheets(1).Range("I1") = "Text" Then '>>>>> ThisWorkbook.Sheets(1).Cells(lr, 2) = "vorhanden" Else ThisWorkbook.Sheets(1).Cells(lr, 2) = "nicht vorhanden" End If lr = lr + 1 End If WB.Close 0 Next i Application.ScreenUpdating = True set WB = nothing End Sub

Private Declare Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As _ String) As Long Public Function F_ASC_ANS(ByVal Text As String) As String OemToCharA Text, Text F_ASC_ANS = Text End Function Sub F_en() Dim WB As Workbook lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 Application.ScreenUpdating = False '########################################################################## Directory anpassen # _ fn = Split(F_ASC_ANS(CreateObject("wscript.shell").exec("cmd /c Dir ""C:\temp\*.xlsx"" /b/s" _ ).stdout.readall), vbCrLf) For i = 0 To UBound(fn) - 1 Application.StatusBar = i & ": " & fn(i) Pa = Split(fn(i), "\") ThisWorkbook.Sheets(1).Cells(lr, 1) = Pa(UBound(Pa) - 1) 'Name des Directories Set WB = GetObject(fn(i)) If WB.Sheets(1).Range("I1") = "Text" Then '>>>>> ThisWorkbook.Sheets(1).Cells(lr, 2) = "vorhanden" Else ThisWorkbook.Sheets(1).Cells(lr, 2) = "nicht vorhanden" End If lr = lr + 1 WB.Close 0 Next i Application.ScreenUpdating = True set WB = nothing End Sub

Nach einem ersten test funktioniert es super bis auf:
Ist die Datei im zweiten Unterordner (im Bezug auf den Ordner der die Produktnummer enthält)
dann bekomme ich trotzdem den darüberstehenden Ordner als Name ins sheet geschrieben und dieser heißt meist "PPAP", der darüber Lieferant etc
ich denke, ich werde eine geschachtele if abfrage implementieren welche die Hierarchieebene so lange um 1 reduziert bis isNumeric true ist...funktioniert das so?
und Verständnißfrage:
Private Declare Function OemToCharA Lib "user32.dll" (ByVal lpszSrc As String, ByVal lpszDst As _
String) As Long

Public Function F_ASC_ANS(ByVal Text As String) As String
OemToCharA Text, Text
F_ASC_ANS = Text
End Function

Was machen diese Zeilen und warum sind sie nötig? Danke :D

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread