Makro - Ordnernamen mit Excel abgleichenen

Hallo,
ich habe folgendes Problem beim Erstellen einer Makro:
Schritt 1:
Die Makro soll die verschiedenen Ordnernamen (XXXX,YYYY,ZZZZ) aus dem Verzeichnis "C:\Temp\Nummern" auf die ersten 4 Zahlen prüfen (manchmal auch nur 3 Zahlen).
Schritt 2:
Diese Zahlen sollen dann in Spalte A der Excel "C:\Temp\Datei.xlsx" wieder gefunden werden.
Schritt 3:
Anschließend soll jeweils die in Spalte B daneben stehende Code (111,222,333) gelesen werden, um den dazugehörigen Ordner (111,222,333) im Verzeichnis "C:\Temp\CODES" wieder zu finden.
Schritt 4:
Und jetzt zum Schluss sollen die Ordner aus "Nummern" (XXXX,YYYY,ZZZZ) jeweils in die zugehörigen Ordner in "CODES" verschoben werden.
Es ist im Grunde also eine Art Ordner-Sortier-Verschiebaufgabe, die man hoffentlich irgendwie mit einer Makro lösen kann. Leider übersteigt das meine Excel Basiskentnisse :/
Ich freue mich über jede Antwort / Hilfe
beste Grüsse
Manfred

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Verschieben() Dim lngAnf As String Dim datei As String Dim fol As Folder Dim folNum As Folder Dim letzteZeile As Long Dim fso As FileSystemObject Dim pfad As String Dim pfadCOD As String Dim pfadNum As String Dim suchErgebnis As Object Dim unterVerzeichnis As String Dim wb As Workbook Dim ws As Worksheet Dim zeile As Long pfad = "C:\Temp\" pfadCOD = "C:\Temp\CODES\" pfadNum = "C:\Temp\Nummern" datei = "Datei.xlsx" If Dir(pfad & datei) = "" Then MsgBox pfad & datei & " existiert nicht" Exit Sub End If On Error Resume Next Workbooks(datei).Close On Error GoTo 0 Set wb = Workbooks.Open(Filename:=pfad & datei) Set ws = wb.Worksheets(1) letzteZeile = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set fso = New FileSystemObject If Not fso.FolderExists(pfadNum) Then MsgBox pfadNum & " existiert nicht" GoTo Ende End If Set folNum = fso.GetFolder(pfadNum) If Not fso.FolderExists(pfadCOD) Then MsgBox pfadCOD & " existiert nicht" Exit Sub GoTo Ende End If For Each fol In folNum.SubFolders If IsNumeric(Left$(fol.Name, 4)) Or _ IsNumeric(Left$(fol.Name, 3)) Then If IsNumeric(Left$(fol.Name, 4)) Then lngAnf = CLng(Left$(fol.Name, 4)) Else lngAnf = CLng(Left$(fol.Name, 3)) End If Set suchErgebnis = ws.Columns("A").Find(What:=lngAnf, _ LookAt:=xlWhole) If Not suchErgebnis Is Nothing Then zeile = suchErgebnis.Row unterVerzeichnis = ws.Cells(zeile, "B") If fso.FolderExists(pfadCOD & unterVerzeichnis) Then fol.Move Destination:=pfadCOD & unterVerzeichnis & "\" End If End If End If Next fol Ende: wb.Close Set fso = Nothing End Sub

Hallo Manfred,
bei der Ordnerstruktur konnte das nicht funktionieren. Ich habe nach Ordnern gesucht, deren Namen genau dem Code in Spalte B entsprachen.
Das ergänzte Programm sieht folgendermaßen aus:

Sub Verschieben()
Dim lngAnf As String
Dim datei As String
Dim fol As Folder
Dim folCOD As Folder
Dim folNum As Folder
Dim länge As Long
Dim letzteZeile As Long
Dim fso As FileSystemObject
Dim pfad As String
Dim pfadCOD As String
Dim pfadNum As String
Dim präfix As String
Dim sfol As Folder
Dim suchErgebnis As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim zeile As Long
pfad = "C:\Temp\"
pfadCOD = "C:\Temp\CODES\"
pfadNum = "C:\Temp\Nummern"
datei = "Datei.xlsx"
If Dir(pfad & datei) = "" Then
MsgBox pfad & datei & " existiert nicht"
Exit Sub
End If
On Error Resume Next
Workbooks(datei).Close
On Error GoTo 0
Set wb = Workbooks.Open(Filename:=pfad & datei)
Set ws = wb.Worksheets(1)
letzteZeile = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set fso = New FileSystemObject
If Not fso.FolderExists(pfadNum) Then
MsgBox pfadNum & " existiert nicht"
GoTo Ende
End If
Set folNum = fso.GetFolder(pfadNum)
If Not fso.FolderExists(pfadCOD) Then
MsgBox pfadCOD & " existiert nicht"
Exit Sub
GoTo Ende
End If
Set folCOD = fso.GetFolder(pfadCOD)
For Each fol In folNum.SubFolders
If IsNumeric(Left$(fol.Name, 4)) Or _
IsNumeric(Left$(fol.Name, 3)) Then
If IsNumeric(Left$(fol.Name, 4)) Then
lngAnf = CLng(Left$(fol.Name, 4))
Else
lngAnf = CLng(Left$(fol.Name, 3))
End If
Set suchErgebnis = ws.Columns("A").Find(What:=lngAnf, _
LookAt:=xlWhole)
If Not suchErgebnis Is Nothing Then
zeile = suchErgebnis.Row
präfix = ws.Cells(zeile, "B")
länge = Len(präfix)
For Each sfol In folCOD.SubFolders
If Left$(sfol.Name, länge) = präfix Then
fol.Move Destination:=sfol.Path & "\"
End If
Next sfol
End If
End If
Next fol
Ende:
wb.Close
Set fso = Nothing
End Sub

https://www.herber.de/bbs/user/121787.xlsm
Falls du noch Nachfragen hast, ich kann mich erst Anfang der nächsten Woche wieder darum kümmern.
Viele Grüße
Dieter

Beliebteste Forumthreads (12 Monate)

Makro - Ordnernamen mit Excel abgleichenen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread