Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1728to1732
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Über Dateinamen Ordner erstellen und Dateien verschieben

Über Dateinamen Ordner erstellen und Dateien verschieben
09.12.2019 11:29:56
Mario
Guten Morgen,
zum einen erstmal vielen Dank für dieses großartige Forum und euch unglaublich hilfsbereiten Mitglieder. Bisher konnte ich alle meine Scripte durch mitlesen, lernen und entsprechend ändern problemlos anpassen. Jetzt bräuchte ich allerdings doch mal eure direkte Hilfe.
Ich habe eine Excel erstellt die mir verschiedene Anfragen als PDF erstellt und in einem Ordner speichert. Dabei haben alle PDF-Dateien einen ähnlichen Namen, z.b. "LST 123456789.PDF", "Bestellung 987654321.pdf" etc. Es ist immer eine 9-stellige Nummer vor dem Punkt mit der Dateiendung.
Ich möchte jetzt gerne einen Button einbinden dessen Script soll dann in einem bestimmten Ordner nachsehen ob Dateien vorhanden sind, wenn ja diese entsprechend der 9-stelligen Nummer im Dateinamen in einen Ordner mit dieser 9-Stelligen Zahl verschieben. Wenn der Ordner nicht existiert, dann erst erstellen und dann verschieben.
Ich habe ein Script hier gefunden das etwas ähnliches durchführt. Nur komme ich nicht drauf wie ich nur die letzten 9 Stellen des Dateinamens benutzen kann, und wie ich die Schleife aufbauen muss, damit das Script so lange durchläuft bis keine Datei mehr im Ordner vorhanden ist.
Hier mal das gefundene Script:
Sub File_verschieben()
Dim Quelle$, Ziel$, FSO As Object
Quelle = "C:\abc\LN*.*"
If Dir(Quelle) = "" Then
MsgBox "Keine Dateien vorhanden!"
Else
Ziel = "V:\xyz\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Quelle, Ziel
Set FSO = Nothing
End If
End Sub
Könnt Ihr mit bitte bei dem Problem helfen ?
vielen Dank für eure Mühe.
Mario

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

Betreff
Datum
Anwender
Anzeige
AW: Über Dateinamen Ordner erstellen und Dateien verschieben
09.12.2019 12:14:24
Mario
Ich hätte es jetzt im Prinzip so erstellt:
    Dim Quelle$, Ziel$, FSO As Object
While Dir(Quelle)  ""
Quelle = "D:\Users\BKU\mariodittrich\Desktop\Baumappe\EM IH*.pdf"
Quelle = "D:\Users\BKU\mariodittrich\Desktop\Baumappe\LST IH*.pdf"
Quelle = "D:\Users\BKU\mariodittrich\Desktop\Baumappe\FWD Bestellung IH*.pdf"
Quelle = "D:\Users\BKU\mariodittrich\Desktop\Baumappe\1. Seite IH*.pdf"
If Dir(Quelle) = "" Then
MsgBox "Keine Dateien vorhanden!"
Else
Ziel = "D:\Users\BKU\mariodittrich\Desktop\Baumappe 2\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Quelle, Ziel
'Set FSO = Nothing
End If
Wend
allerdings überschreibe ich ja so jedes mal die Variable Quelle, so dass nur die letzte Zeile bearbeitet wird. (Bei c++ würde ich eine Schleife mit einem Inkrementor nehmen, in VBA hab ich keine Ahnung)
Ausserdem kopiert er es ja so in einen fixen Ordner, und nicht in einen der zu der Nummer passt.
Steh komplett aufm Schlauch.
Anzeige
AW: Über Dateinamen Ordner erstellen und Dateien verschieben
09.12.2019 12:22:35
Nepumuk
Hallo Mario,
teste mal:
Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare PtrSafe Function MoveFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String) As Long

Public Sub File_verschieben()
    
    Const SOURCE_FOLDER As String = "H:\1209\" ' Anpassen !!!
    Const TARGET_FOLDER As String = "G:\1209\" ' Anpassen !!!
    
    Dim strFileName As String, strTargetFolder As String
    Dim lngNumber As String, lngCounter As Long
    
    On Error GoTo err_exit
    
    strFileName = Dir$(SOURCE_FOLDER & "*.pdf")
    
    Do Until strFileName = vbNullString
        lngNumber = ExtractNumber(strFileName)
        If lngNumber > 0 Then
            strTargetFolder = TARGET_FOLDER & CStr(lngNumber) & "\"
            If MakeSureDirectoryPathExists(strTargetFolder) = 0 Then
                Call Err.Raise(Number:=vbObjectError + 70, Description:="Zugriffsfehler")
            Else
                If MoveFileA(SOURCE_FOLDER & strFileName, strTargetFolder & strFileName) = 0 Then
                    Call Err.Raise(Number:=vbObjectError + 1004, Description:="Kopierfehler")
                End If
            End If
            lngCounter = lngCounter + 1
        End If
        strFileName = Dir$
    Loop
    If lngCounter = 0 Then
        Call MsgBox("Keine Dateien zum verschieben gefunden.", vbExclamation, "Hinweis")
    Else
        Call MsgBox(CStr(lngCounter) & " Dateien verschoben.", vbInformation, "Information")
    End If
    Exit Sub
    err_exit:
    Call MsgBox("Fehler " & CStr(Err.Number) & vbLf & vbLf & Err.Description, vbCritical, "Fehler")
End Sub

Private Function ExtractNumber(ByVal prstrFileName As String) As Long
    Dim objRegEx As Object, objMatch As Object
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "\d{9}"
        Set objMatch = .Execute(prstrFileName)
    End With
    If objMatch.Count > 0 Then ExtractNumber = objMatch.Item(0)
End Function

Gruß
Nepumuk
Anzeige
AW: Über Dateinamen Ordner erstellen und Dateien verschieben
09.12.2019 12:36:49
Mario
WOW !
Perfekt. Vielen vielen Dank für deine Unterstützung ! Das funktioniert ja perfekt.
Jetzt muss ich mich mal damit beschäftigen und Schritt für Schritt lernen was es genau tut.
Vielen Dank an dich nochmal !
Gruss
Mario

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige