ich benötige mal wieder Eure Hilfe.
Mit nachfolgendem Code kopiere ich Daten von einem Pfad, der in einem Dialogfenster ausgewählt werden kann, in ein feststehendes Verzeichnis. Das funktioniert auch super. Hier erst mal das Makro:
Sub Listen_kopieren()
Dim PfadZiel As String
Dim Zähler As Integer
Dim Pfad As String
Dim DirDatei As String
If Workbooks(WorkbookName).Sheets("Hilfstabelle").Range("AY3") = "" Then _
PfadZiel = Mid(ThisWorkbook.path, 1, Len(ThisWorkbook.path) - 8) & "Preislisten"
If Workbooks(WorkbookName).Sheets("Hilfstabelle").Range("AY3") "" Then _
PfadZiel = Workbooks(WorkbookName).Sheets("Hilfstabelle").Range("AY3")
Pfad = GetDirectory("Bitte Ordner auswählen, aus dem die Objektlisten kopiert werden soll.")
'Wenn Abbruch-Taste betätigt wird, Prozedur beenden
If Pfad = "" Then Exit Sub
'Backslash am Ende des Pfades anfügen wenn fehlt
If Right(Pfad, 1) "/" Then _
Pfad = Pfad & "\"
'Backslash am Ende des Pfades anfügen wenn fehlt
If Right(PfadZiel, 1) "/" Then _
PfadZiel = PfadZiel & "\"
If Pfad = PfadZiel Then
MsgBox "Bei dem ausgesuchten Pfad handelt es sich um den Pfad, in das die Objektlisten kopiert " _
_
& "werden. Der Vorgang wird abgebrochen", vbInformation, "Immorente - Abbruch..."
Exit Sub
End If
'----------------------------------------------------------------------------------------------- _
'Prüfen ob ausgewähltes Verzeichnis Objektlisten enthält
Zähler = 0
DirDatei = Dir(Pfad & "*.xls")
Do While DirDatei ""
If LCase(Left(DirDatei, 15)) = "stellplatzliste" Or LCase(Left(DirDatei, 7)) = "objekt_" Then
Zähler = Zähler + 1
End If
DirDatei = Dir()
Loop
If Zähler = 0 Then
MsgBox "Unter dem von Ihnen ausgewähltem Pfad wurde keine Objekt- oder Stellplatzlisten _
gefunden. " _
& "Es wurden keine Daten kopiert.", vbInformation, "Immorente - Datenimport fehlgeschlagen..."
Exit Sub
End If
'----------------------------------------------------------------------------------------------- _
'Objektlisten kopieren
Zähler = 0
DirDatei = Dir(Pfad & "*.xls")
Do While DirDatei ""
If LCase(Left(DirDatei, 15)) = "stellplatzliste" Or LCase(Left(DirDatei, 7)) = "objekt_" Then
FileCopy Pfad & DirDatei, PfadZiel & DirDatei
Zähler = Zähler + 1
End If
DirDatei = Dir()
Loop
If Zähler > 0 Then
MsgBox "Es wurden " & Zähler & " Objekt- und Stellplatzlisten erfolgreich " _
& "importiert.", vbInformation, "Immorente - Datenimport..."
End If
End Sub
Allerdings wäre es nun noch schön, wenn vor dem Kopieren geprüft würde, ob die zu kopierende Datei bereits in dem Verzeichnis vorhanden ist. Wenn ja, soll die Datei nicht kopiert werden. Gibt es die Datei noch nicht, soll sie kopiert werden. Ich habe es mit einer 2. Do/Loop-Anweisung versucht, allerdings funktionierte das nicht. Hat jemand eine Idee, wie ich das realisieren kann?
Danke Euch schon mal,
Kasimir