Office: Daten abgleichen Ordner Unterordner

Hallo,

habe das schon in einem anderen Forum gepostet, die Lösung von mase verstehe ich nicht!

Das Problem:

Ich möchte Zellen aus einer Tabelle mit Dateinamen aus einem Ordner und Unterordnern vergleichen und sollten sie übereinstimmen wird die Datei in einen Zielordner kopiert. Das Beispiel aus dem Netz funktioniert auch soweit und konnte auf meine Bedürfnisse umgeschrieben werden.

Wie beziehe ich in diesem Beispiel mögliche Unterordner ein? Wenn eine Name der Liste nicht als Datei vorhanden ist soll er nicht aus dem Programm aussteigen, sondern die Liste weiter abarbeiten!

Den Quell- und Zielpfad habe ich für mich so gestaltet, dass er von einer Range, zB. C8 übernommen wird. das funzt auch! Hier ist das leicht geänderte Beispiel, das ich nicht so hinbekommen, also Unterordner abgleichen und bei nicht vorhandener Datei weiter abarbeiten

Es wäre super wenn mir jemand helfen könnte! DANKE!




Sub Test()
Dim i As Long
Dim myFSo As Object
Dim sPath As String
Dim sPath2 As String

sPath = Worksheets("TEST").Range("C8")
sPath2 = Worksheets("TEST").Range("C9")

With Worksheets("NEU")
Const sSpalte As Long = 1



For i = 1 To Cells(Rows.Count, sSpalte).End(xlUp).Row
'ist zelleninhalt vorhanden
If Cells(i, sSpalte) > "" Then
'ist datei im angegebenen Ordner vorhanden


If Dir(sPath & Cells(i, sSpalte)) > "" Then

Set myFSo = CreateObject("Scripting.FileSystemObject")

myFSo.CopyFile sPath & Cells(i, sSpalte) sPath2 & Cells(i, sSpalte) , True


End If
End If


Next i


End With
End Sub

Habe im Netz diese Lösung gefunden! Geht bei mir aber nicht!





If FindFile(sPath & Cells(i, sSpalte) ) > "" Then

Gibt er aus: Argument ist nicht optional

Option Explicit

Dim FSO, FO, FU, F

Sub Dateien_prüfen()
Dim i As Long ' Zählwert für Reihe
Const sPath As String = "D:a.noackDev" '"C:UsersfritzDocumentsBeruf" 'ANPASSEN
Const sSpalte As Long = 1 'Spalte 1 im Reparaturbuch

'Alle Zellen der angebenen Spalte durchlaufen
For i = 1 To Cells(Rows.Count, sSpalte).End(xlUp).Row
'Ist ein Zelleninhalt vorhanden?
If Cells(i, sSpalte) > "" Then
'Ist die Datei im angegebenen Ordner vorhanden?
If FindFile(sPath, Cells(i, sSpalte) & ".xls") > "" Then
'wenn ja, dann Zeile grau hinterlegen
Cells(i, 1).EntireRow.Interior.ColorIndex = 15
Else
'wenn nein, dann Zeile rot hinterlegen
Cells(i, 1).EntireRow.Interior.ColorIndex = 0
'Cancel = True
End If
End If
Next i
End Sub


Public Function FindFile(sPath As String, sFile As String) As String
Set FSO = CreateObject("Scripting.FileSystemObject")

FindFile = GetSubFolders(sPath, sFile)
End Function

Private Function GetSubFolders(sPath As String, sFile As String) As String
On Error GoTo errHandler

Set FO = FSO.GetFolder(sPath)
Set FU = FO.SubFolders

On Error Resume Next

For Each F In FU
If Dir(F.Path & "" & sFile) > "" Then
GetSubFolders = F.Path
Exit For
End If

GetSubFolders F.Path, sFile
Next

Exit Function

errHandler:
GetSubFolders = ""
End Function

:)

 

Hallo Hans2020,

das hatte Ich bereits im anderen Forum.
Warum versucht Du nicht Deine Prüfung und das Kopieren einzubauen?

Code:

X-Post

 

Hola,

edit: obsolet.

Gruß,
steve1da

 

Weil ich es nicht verstehe! Sorry!

Warum geht denn die andere Lösung aus dem Netz bei mir nicht? Die passt doch zu meinem Grundgerüst?

 

If FindFile(sPath & Cells(i, sSpalte) ) > "" Then

Argument ist nicht optional ist die Fehlermeldung!

 

Hat keiner einen Tipp für mich?

 

So! Jetzt geht es!

Aber das Makro macht nicht was es soll! Jetzt durchsucht es die Unterordner und gleicht die Dateien ab! Diese werden in der Tabelle auch grau hinterlegt! Die Dateien der Hauptebene werden nicht grau hinterlegt! Die nicht vorhandenen werden auch nicht rot hinterlegt!

Was ist nun noch falsch?





Public Sub TEST()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim rngCell As Range
Dim cDir As String, sListe As String
Dim i As Long
Dim myFSo As Object
Dim x As Long
Dim lZeile As Long
Dim lAnzahlDateien As Long
Dim sPath As String
Dim sPath2 As String
Dim k As Long
Dim strSubFolder As Variant
Dim sourceFolder As Object, SubFolder As Object, strFilename$, strFilenameOld$, j&
Dim sFile As String


ThisWorkbook.Worksheets.Add.Name = "LLL"

With Worksheets("Test")
ZeileMax = .UsedRange.Rows.Count
n = 1
lZeile = 15



For Zeile = 2 To ZeileMax

If .Cells(Zeile, 34).Value = "2" Then

.Rows(Zeile).Copy Destination:=Worksheets("LLL").Rows(n)
n = n + 1

End If
Next Zeile
End With

Worksheets("LLL").Cells.NumberFormat = "@"










sPath2 = Worksheets("TEST2").Range("C9")
sPath = Worksheets("TEST2").Range("C8")



With Worksheets("LLL")
Const sSpalte As Long = 1
End With






sListe = "Datei" & vbCrLf
'Alle zellen der angebenen Spalte durchlaufen

For i = 1 To Cells(Rows.Count, sSpalte).End(xlUp).Row
'ist zelleninhalt vorhanden
If Cells(i, sSpalte) > "" Then


If FindFile(sPath, Cells(i, sSpalte) & ".xlsm") > "" Then

'wenn ja, dann in Meldung ausgeben

Cells(i, 1).EntireRow.Interior.ColorIndex = 15
Else
'wenn nein, dann Zeile rot hinterlegen
Cells(i, 1).EntireRow.Interior.ColorIndex = 0
'Cancel = Tru

End If
End If



Next i








End Sub
Public Function FindFile(sPath As String, sFile As String) As String
Set FSO = CreateObject("Scripting.FileSystemObject")

FindFile = GetSubFolders(sPath, sFile)
End Function

Private Function GetSubFolders(sPath As String, sFile As String) As String
On Error GoTo errHandler

Set FO = FSO.GetFolder(sPath)
Set FU = FO.SubFolders

On Error Resume Next

For Each F In FU
If Dir(F.Path & "" & sFile) > "" Then
GetSubFolders = F.Path
Exit For
End If

GetSubFolders F.Path, sFile
Next

Exit Function

errHandler:
GetSubFolders = ""
End Function

 

Bin am Verzweifeln! Kann keiner helfen? Möchte keiner helfen? Bitte!

 

If FindFile(sPath, Cells(i, sSpalte)) > "" Then

'wenn ja, dann in Meldung ausgeben

FileCopy FindFile(sPath, Cells(i, sSpalte)) & Test, sPath2 & Cells(i, sSpalte)

Warum bricht er nach der ersten Datei ab obwohl später ein Next i kommt

 

Hola,

nur mal zwischendurch: auf kostenlose Hilfe darf man schon mal etwas warten! Nicht jeder sitzt hier und wartet dass du ein Problem postest - das geschieht nämlich alles freiwillig und in der Freizeit.
Wenn du natürlich einen Dienstleister beauftragst kannst du so oft nachfragen wie du willst.

Just my 2 Cents.

Gruß,
steve1da

 

Ist mir schon klar! Sorry!

 

Moin Hans,

Ich biete Dir support auf Basis meines Weges an.
Entweder Du gehst diesen mit oder wartest auf weitere Antworten - Deine Entscheidung -

My way:
a) Mach ne Datensicherung Deiner Datei (!)
b) Nimm diesen Code in ein Modul und führe diesen aus
c) prüfe im Arbeitsblatt "Meilenstein", ob all die Dateinamen auftauchen, welche Du mit Deiner Liste abgleichen willst und gib Rückmeldung ob iO oder niO


Code:

 

Ohh Danke!

Habe es probiert, den Startpfad geändert! Fehler:

For Each fldr In fso.GetFolder(sPfad).subFolders
Pfad nicht gefunden!

 

Jetzt wäre doch interessant, welchen Pfad Du angegeben hast.

Hinweis:
\

 

Tja, mein Fehler! Pfad falsch angegeben! Er listet alle Dateien des Pfades und der Unterverzeichnisse auf! Ja! Diese möchte ich mit der Liste abgleichen und nur die kopieren die in der Liste vorhanden sind!