Microsoft Excel

Herbers Excel/VBA-Archiv

Dateioperationen:

Betrifft: Dateioperationen: von: Gerald
Geschrieben am: 13.08.2020 13:51:26

Ich bastele an einen VBA Codeschnipsel, der folgende Dateioperationen durchführen soll.

A) C:\source\ (einschließlich Unterverzeichnisse)

B) C:\compare\ (einschließlich Unterverzeichnisse)

C) C:\destination


Alle Dateien aus A sollen mit B verglichen werden, um die Dateien,

- die noch nicht in B existieren sowie

- Dateien, die in A neuer sind als in B

nach C zu kopieren.


Um es richtig schwierig zu machen, können A und B beliebige Unterverzeichnisse haben, in denen die Files liegen.


Ich komme hier nicht weiter; hat jemand eine Idee?

Betrifft: AW: Dateioperationen:
von: Nepumuk
Geschrieben am: 13.08.2020 16:56:29

Hallo Gerald,

im Prinzip so:

Option Explicit

Public Sub Gerald()
    
    Const FOLDER_PATH_1 As String = "C:\source\"
    Const FOLDER_PATH_2 As String = "C:\compare\"
    Const FOLDER_PATH_3 As String = "C:\destination\"
    
    Dim objDictionary_1 As Object, objDictionary_2 As Object
    Dim astrFolders() As String, strFilename As String
    Dim ialngFolders As Long
    Dim vntItem As Variant
    
    Set objDictionary_1 = CreateObject(Class:="Scripting.Dictionary")
    astrFolders = GetFolders(FOLDER_PATH_1)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
        Do Until strFilename = vbNullString
            Call objDictionary_1.Add(Key:=strFilename, Item:=astrFolders(ialngFolders) & strFilename)
            strFilename = Dir$
        Loop
    Next
    
    Set objDictionary_2 = CreateObject(Class:="Scripting.Dictionary")
    astrFolders = GetFolders(FOLDER_PATH_2)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
        Do Until strFilename = vbNullString
            Call objDictionary_2.Add(Key:=strFilename, Item:=astrFolders(ialngFolders) & strFilename)
            strFilename = Dir$
        Loop
    Next
    
    For Each vntItem In objDictionary_1.Keys
        If objDictionary_2.Exists(Key:=vntItem) Then
            If FileDateTime(PthName:=objDictionary_1.Item(Key:=vntItem)) > _
                FileDateTime(PthName:=objDictionary_2.Item(Key:=vntItem)) Then _
                Call FileCopy(Source:=objDictionary_1.Item(Key:=vntItem), Destination:=FOLDER_PATH_3 & vntItem)
        Else
            Call FileCopy(Source:=objDictionary_1.Item(Key:=vntItem), Destination:=FOLDER_PATH_3 & vntItem)
        End If
    Next
    
    Set objDictionary_1 = Nothing
    Set objDictionary_2 = Nothing
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Redim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    Redim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Da ist jetzt aber noch keine Fehlerprüfung drin ob ein Dateiname in A oder B doppelt vorkommen und ob eine Datei die nach C kopiert werden soll nicht schon vorhanden ist.

Gruß
Nepumuk

Betrifft: AW: Dateioperationen:
von: Nepumuk
Geschrieben am: 13.08.2020 18:01:02

Oops,

da ist noch ein Fehler drin. So passt es:

If FileDateTime(PathName:=objDictionary_1.Item(Key:=vntItem)) > _
    FileDateTime(PathName:=objDictionary_2.Item(Key:=vntItem)) Then _
    Call FileCopy(Source:=objDictionary_1.Item(Key:=vntItem), Destination:=FOLDER_PATH_3 & vntItem)

Gruß
Nepumuk

Betrifft: AW: Dateioperationen:
von: Gerald
Geschrieben am: 14.08.2020 11:40:32

Vielen Dank für deine Mühe!
Genau verstanden habe den Code noch nicht (arbeite daran:-). Erste Tests sind schon vielversprechend.
Tatsächlich kommen Dateinamen in A und B mehrfach doppelt vor, sodass das Programm dann aussteigt.

Kann man die doppelten Einträge irgendwie aus „strFilename“ herauszufiltern?

Betrifft: AW: Dateioperationen:
von: Nepumuk
Geschrieben am: 14.08.2020 17:57:52

Hallo Gerald,

sollen doppelte Dateinamen einfach ignoriert werden?

Gruß
Nepumuk

Betrifft: AW: Dateioperationen:
von: Gerald
Geschrieben am: 18.08.2020 10:09:39

Hallo Nepumuk,
Habe etwas gebraucht um die Quelldateien zu analysieren.
Doppelte Dateinamen in A (Source) sind immer identische Files und müssen nur einmal berücksichtigt werden.
Doppelte Dateinamen in B (Compare) sind nicht zwangsläufig gleich.
Gruß
Gerald

Betrifft: AW: Dateioperationen:
von: Nepumuk
Geschrieben am: 18.08.2020 13:07:36

Hallo Gerald,

ok, A ist kein Problem. Aber wie sollen zwei Dateien mit dem selben Namen in B behandelt werden? Z.B. ist eine älter als die Datei in A und eine jünger.

Gruß
Nepumuk

Betrifft: AW: Dateioperationen:
von: Gerald
Geschrieben am: 18.08.2020 15:15:08

Hallo Nepumuk,
Eine Datei in A (Source) muss gegen die neueste gleichnamige Datei in B (compare) verglichen werden. Wenn A neuer als B dann in C kopieren, sonst nicht.
Gruß
Gerald

Betrifft: AW: Dateioperationen:
von: Nepumuk
Geschrieben am: 18.08.2020 16:08:01

Hallo Gerald,

teste mal:

Option Explicit

Private Declare PtrSafe Function CopyFileA Lib "kernel32.dll" ( _
    ByVal lpExistingFileName As String, _
    ByVal lpNewFileName As String, _
    ByVal bFailIfExists As Long) As Long

Public Sub Gerald()
    
    Const FOLDER_PATH_1 As String = "C:\source\"
    Const FOLDER_PATH_2 As String = "C:\compare\"
    Const FOLDER_PATH_3 As String = "C:\destination\"
    
    Dim objDictionary_1 As Object, objDictionary_2 As Object
    Dim adtmFileDate() As Date
    Dim astrFolders() As String, strFilename As String
    Dim ialngFolders As Long, ialngFileDate As Long
    Dim vntItem As Variant
    
    Set objDictionary_1 = CreateObject(Class:="Scripting.Dictionary")
    astrFolders = GetFolders(FOLDER_PATH_1)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
        Do Until strFilename = vbNullString
            If Not objDictionary_1.Exists(Key:=strFilename) Then _
                Call objDictionary_1.Add(Key:=strFilename, Item:=astrFolders(ialngFolders) & strFilename)
            strFilename = Dir$
        Loop
    Next
    
    Set objDictionary_2 = CreateObject(Class:="Scripting.Dictionary")
    astrFolders = GetFolders(FOLDER_PATH_2)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFilename = Dir$(PathName:=astrFolders(ialngFolders) & "*.*")
        Do Until strFilename = vbNullString
            If Not objDictionary_2.Exists(Key:=strFilename) Then
                Call objDictionary_2.Add(Key:=strFilename, Item:=ialngFileDate)
                Redim Preserve adtmFileDate(ialngFileDate)
                adtmFileDate(ialngFileDate) = FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename)
                ialngFileDate = ialngFileDate + 1
            Else
                If FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename) > _
                    adtmFileDate(objDictionary_2.Item(Key:=strFilename)) Then _
                    adtmFileDate(objDictionary_2.Item(Key:=strFilename)) = _
                    FileDateTime(PathName:=astrFolders(ialngFolders) & strFilename)
            End If
            strFilename = Dir$
        Loop
    Next
    
    For Each vntItem In objDictionary_1.Keys
        If objDictionary_2.Exists(Key:=vntItem) Then
            If FileDateTime(PathName:=objDictionary_1.Item(Key:=vntItem)) > _
                adtmFileDate(objDictionary_2.Item(Key:=vntItem)) Then _
                Call CopyFileA(objDictionary_1.Item(Key:=vntItem), FOLDER_PATH_3 & vntItem, 0)
        Else
            Call CopyFileA(objDictionary_1.Item(Key:=vntItem), FOLDER_PATH_3 & vntItem, 0)
        End If
    Next
    
    Set objDictionary_1 = Nothing
    Set objDictionary_2 = Nothing
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Redim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    Redim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Gruß
Nepumuk

Betrifft: AW: Dateioperationen:
von: Gerald
Geschrieben am: 19.08.2020 11:44:53

Ich werde ausfühlich testen und mich melden.
Vielen Dank!