Hallo
ich habe das Ordner auflisten Programm noch mal geändert, Spalten verschoben für eine Suchlauf. Die Eingabe der Ordnerpfad ist Zelle C1 und G1
Neu ist ein Suchlauf der aus Spalte C in der Spalte G nach relevanten Ordnern sucht und den Ordnerpfad des Zielordner in Spalte D anzeigt.
Wenn das alles einwandfrei klappt, und du damit zurecht kommst, kann ich ein drittes Makro für das verschieben schreiben. Weil ich deine Datei nicht auf dem Rechner habe und auch keine Beispieldatei kann ich nicht prüfen ob mit deinen Daten alles richtig läuft. Das musst du bitte selbst testen.
Die Makros kannst du über normale CommandButton starten und das Makro direkt zuweisen. Bei AktiveX Steuerelemente geht das Nicht!!
Für heute genug getan ... Morgen ist auch noch ein Tag.
mfg Nobody
Option Explicit
Dim lngCount As Long
'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(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, 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
######## Suchlauf nach Zielordnern
Option Explicit
Dim AC As Range, lz1 As Long
Dim Adr1 As String, rFind As Range
Sub Ordner_suchen()
Dim SuName As String, n, Txt As String
With ThisWorkbook.Worksheets("Tabelle4")
.Range("E4:E1000").Clear
lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
For Each AC In .Range("C5:C" & lz1)
If AC.Value = Empty Or InStr(AC, ":") Then GoTo nx
SuName = Left(AC, InStrRev(AC, ".") - 1)
Set rFind = .Columns(7).Find(What:=SuName, After:=[g5], LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not rFind Is Nothing Then
Adr1 = rFind.Address: n = 0
Do
If InStr(rFind, ":") Then
Txt = AC.Offset(0, 1) 'dopp. Test
If Txt <> "" Then Txt = ", " & Txt
AC.Offset(0, 1) = rFind.Value & Txt
n = n + 1
End If
Set rFind = .Columns(7).FindNext(rFind)
Loop Until rFind.Address = Adr1
If n > 1 Then AC.Offset(0, 1).Font.ColorIndex = 3
nx: End If
Next AC
End With
End Sub
|