Hallo zusammen,

ich arbeite zur Zeit an einer kleinen VBA Anwendung und komme an einer Stelle nicht weiter. Nach Stundenlanger Recherche Im Internet, muss ich hier mal die Profis fragen. Mir liegt eine Excelliste vor wo in Spalte "H" untereinander ein Text steht. Dieser Text soll in einem bestimmten Verzeichnis jeweils einen Ordner (mit den Bezeichnungen aus Spalte "H") erzeugen. Dies habe ich mit folgenden Skript gelöst:

Sub Ordner_anlegen()
Dim sDir As String, sVerz As String, iRow As Integer
iRow = 1

Do Until IsEmpty(Cells(iRow, 8))
sVerz = Cells(iRow, 8).Value
sDir = "C:\temp\Test\" & sVerz
On Error Resume Next
MkDir sDir
iRow = iRow + 1
Loop
End Sub

Jetzt zu meinem Problem:
In Spalte "A" ist ein Text vorhanden. Dieser Text Bestandteil eines Namen einer oder mehrerer Dateien in einem seperaten Ordner. Ich möchte nun prüfen ob die Datei(en) mit der Teilbezeichnung aus z.B. Zelle "A1" im Ordner gefunden wird und wenn ja verschiebe diese Datei(en) in den vorab erstellten Ordner aus Zelle "H1".
(Gefundene Datei(en) von "A2" in Ordner "H2" usw.) Ist das überhaupt möglich?

Für ein Feedback bedanke ich mich im Voraus!

Hallo,

es ist ja immer so.... man sucht zwei Tage verzweifelt nach einer Lösung und dann (nachdem man einen Forumbeitrag geschrieben hat) klappt es doch irgendwie.

Sub Data()
Dim sDir As String, sVerz As String, iRow As Integer
iRow = 1
moveCount = 0
Do Until IsEmpty(Cells(iRow, 8))
pfad = "C:\XYZ\" 'Pfad wo alle Dateien abliegen
sName = Cells(iRow, 1).Value

f = Dir(pfad & "*.tif") 'Dateiendung
sVerz = Cells(iRow, 8).Value
sDir = "C:\123\" & sVerz 'Pfad wo die Ordner erstellt werden sollen
On Error Resume Next
MkDir sDir
While f <> ""
If InStr(f, sName) <> 0 Then
Call FileCopy(pfad & f, sDir & "\" & f)
Call Kill(pfad & f)
moveCount = moveCount + 1
End If

f = Dir
Wend
iRow = iRow + 1
Loop

MsgBox "Es wurden " & moveCount & " Dateien verschoben"
End Sub