Sorry Code an vorheriger Antwort nicht angehangen
wenn du die Auflistung von den Spalten her anders gestaltet haben willst können wir das ändern. Schade das du keine Beispiledatei hochladen kannst! Dann könntest du mir deine Ideen und Lösungsvorschlage von Hand eintragen. Ich warte mal auf deine Antwort ...
mfg Nobody
Option Explicit
Dim lngCount As Long
Public Sub Test_3()
With ThisWorkbook.Worksheets("Tabelle4")
.Range("A4:F1000").Clear
lngCount = 3 '1.Zeile zum auflistern
SearchFiles_Status Range("C1"), "*.*" '"*.pdf"
lngCount = 3 '1.Zeile zum auflistern
SearchFiles_Schäden Range("F1"), "*.*" '"*.pdf"
End With
End Sub
Private Sub SearchFiles_Status(strFolder As String, strFileName As String)
Dim objFolder As Object, d As Integer
Dim objFile As Object, objFSO As Object
With ThisWorkbook.Worksheets(4)
Set objFSO = CreateObject("Scripting.FileSystemObject")
lngCount = lngCount + 2
Cells(lngCount, 3) = strFolder
Cells(lngCount, 3).Font.ColorIndex = 5
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
lngCount = lngCount + 1: d = d + 1
Cells(lngCount, 3) = objFile.Name
End If
Next
If d = 0 Then lngCount = lngCount - 2
For Each objFolder In objFSO.GetFolder(strFolder).SubFolders
SearchFiles_Status strFolder & "\" & objFolder.Name, strFileName
Next
End With
End Sub
Private Sub SearchFiles_Schäden(strFolder As String, strFileName As String)
Dim objFolder As Object, d As Integer
Dim objFile As Object, objFSO As Object
With ThisWorkbook.Worksheets(4)
Set objFSO = CreateObject("Scripting.FileSystemObject")
lngCount = lngCount + 2
Cells(lngCount, 6) = strFolder
Cells(lngCount, 6).Font.ColorIndex = 5
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
lngCount = lngCount + 1: d = d + 1
Cells(lngCount, 6) = objFile.Name
End If
Next
If d = 0 Then lngCount = lngCount - 2
For Each objFolder In objFSO.GetFolder(strFolder).SubFolders
SearchFiles_Schäden strFolder & "\" & objFolder.Name, strFileName
Next
End With
End Sub
########## ab hier Verschiebe Codes
'** Move Test und Ziel Test funktionierren beide!!
'** 1. Variante über FSO System, zweite klappt auch.
Sub Move_Test()
Dim FSO As Object, f1 As Object
quelle = "G:\_Test A\Mappe B.xlsx"
Ziel = "G:\_Test B\Mappe Test B.xlsx"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f1 = FSO.GetFile(quelle)
f1.Move (Ziel)
End Sub
Sub Ziel_Test_()
Dim quelle As String
Dim Ziel As String
quelle = "G:\_Test A\Mappe A.xlsx"
Ziel = "G:\_Test B\Mappe A.xlsx"
Name quelle As Ziel
End Sub
'### Test 3 funktioniert leider NICHT !!
'### Schade, verschiebt ganzen Ordner!!
Sub Test_3()
Const PFAD_A As String = "G:\_Test A\"
Const PFAD_B As String = "G:\_Test B\"
Dim Datei As String
Datei = Dir(PFAD_A, vbDirectory)
Do While Datei <> vbNullString
' If Left(Datei, 2) = "Ma" Then
Name PFAD_A & Datei As PFAD_B & Datei
Datei = Dir
' End If
Loop
End Sub
|