Hallo liebe Experten,
ich bin Änfänger und suche eine Lösung die aus einer veränderlichen Anzahl Unterordner alle enthaltenen Excel Dateien kopiert und in ein anderes Verzeichnis einfügt (besser wäre noch er könnte die Dateien einfach öffnen und Tabelle 1 und 2 aus jedem einzelnen Tabellenblatt drucken, das mache ich im Moment im 2. Schritt.).
Den benutzen Code habe ich per Google gesucht und etwas angepasst, leider hat Excel 2010 nicht mehr die Funktion "FileSearch". Zum Thema FileSearch habe ich (gefühlt) unendliche Versuche unternommen, um den Code mit "fs" oder auch einem Klassenmodul zu ersetzen, leider reicht es bei mir wohl nicht:(
Es wärte toll, wenn mir jemand helfen könnte...DANKE
Hier der Code:
Sub Kopieren_Xl_aus_Unterordner()
Dim i As Long
Dim ZielPath As String
Dim QuellPath As String
Dim NewPath As String
Dim SuchStr As String
QuellPath = "C:\Users\Administrator\Documents\Ablage\Excel\Peter\Zeiterfassung\import\"
ZielPath = "C:\Users\Administrator\Documents\Ablage\Excel\Peter\Zeiterfassung\aktuell\"
SuchStr = "*.xl*"
With Application.FileSearch
.NewSearch
.LookIn = QuellPath
.SearchSubFolders = True
.Filename = SuchStr
.MatchTextExactly = False
.Execute
For i = 1 To .FoundFiles.Count
NewPath = Left(.FoundFiles(i), Len(.FoundFiles(i)) - Len(Dir(.FoundFiles(i))))
NewPath = ZielPath & Right(NewPath, Len(NewPath) - Len(QuellPath))
If CheckDir(NewPath) = False Then
MsgBox "Kopieren fehlgeschlagen!"
Exit Sub
Else
FileCopy .FoundFiles(i), ZielPath & Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(QuellPath))
End If
Next
End With
End Sub
'**** gepostet von rastrans ****
Function CheckDir(ByVal Verzeichnis As String) As Boolean
Dim i As Integer
Dim strNewVerzeichnis As String
If Right(Verzeichnis, 1) <> "\" Then Verzeichnis = Verzeichnis & "\"
On Error GoTo CheckDIR_Exit
i = InStr(4, Verzeichnis, "\")
Do While i > 0
strNewVerzeichnis = Left(Verzeichnis, i)
If Len(Dir(strNewVerzeichnis, vbDirectory)) = 0 Then MkDir (strNewVerzeichnis)
i = InStr(i + 1, Verzeichnis, "\")
Loop
CheckDIR_Exit:
CheckDir = (Err.Number = 0)
End Function
'**************
|