Hallo
mir sind heute doch noch in zwei Modulen Fehler aufgefallen, die sich auf die With Klammer beziehen. Da fehlen bei einigen Cells und Range der Punkt.
Zur Vorishct lade ich die berichtigten Makros noch mal hoch. In allen Modulen findest du den Code: With ThisWorkbook.Worksheets("Tabelle4")
In deiner Datei kannst du das in allen Modulen auf deine eigene Tabelle umbenennen.
mfg Nobody
Modul 1 Auflisten
Option Explicit '28.9.2021 Nobody für VBA Forum
Dim lngCount As Long 'Dateien verschieben Makro
'Zelle C1=Status Ordner, G1=Schäden Ordner
'in diesen Zellen bitte Ordnerpfad angeben
Sub Ordner_auflisten()
With ThisWorkbook.Worksheets("Tabelle4")
.Range("A4:J1000").Clear
lngCount = 3 '1.Zeile zum auflistern
SearchFiles_Status Range("C1"), "*.*" '"*.pdf"
lngCount = 3 '1.Zeile zum auflistern
SearchFiles_Schäden Range("G1"), "*.*" '"*.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("Tabelle4")
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("Tabelle4")
Set objFSO = CreateObject("Scripting.FileSystemObject")
lngCount = lngCount + 2
.Cells(lngCount, 7) = strFolder
.Cells(lngCount, 7).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, 7) = 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
############
Modul 3 Verschieben
Option Explicit '28.9.2021 Nobody für VBA Forum
Dim AC As Range, lz1 As Long
Sub Dateien_verschieben()
Dim quelle As String, n As Integer
Dim Ziel As String, Datei As String
With ThisWorkbook.Worksheets("Tabelle4")
lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
Application.ScreenUpdating = False
For Each AC In .Range("C5:C" & lz1)
If InStr(AC, ":\") Then GoTo nx
If AC.Offset(0, 1) <> Empty Then
Datei = Trim(AC)
quelle = .Range("C1") & "\" & Datei
Ziel = AC.Offset(0, 1) & "\" & Datei
Name quelle As Ziel
n = n + 1
nx: End If
Next AC
MsgBox n & " Dateien verschoben"
Call Ordner_auflisten
End With
End Sub
|