Microsoft Excel

Herbers Excel/VBA-Archiv

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Dateien kopieren

nach unten

Betrifft: Dateien kopieren von: Edgar Höcker
Geschrieben am: 12.10.2020 08:33:36

Hallo,

ich habe ein Problem, an dem ich schon fast eine Woche sitze, aber auch trotz intensiever Suche keine Lösung für mich gefunden habe. Mit FileSearch habe ich eine Lösung, aber FileSearch gibt es ja nicht mehr:

Ich habe einen Ordner DATEN in dem viele Unterordner (U01, U02, bis Unn) enthalten sind. das können durchaus 50 Unterordner sein). In jedem Unterordner sind mehrere Dateien enthalten, aber nur exact eine .XLSX Datei.

Ich möchte jetzt alle XLSX Dateien aus allen Unterordnern in einen Ordner C:\OUTPUT kopieren.

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Nepumuk
Geschrieben am: 12.10.2020 09:21:36

Hallo Edgar,

teste mal:

Option Explicit

Public Sub CopyFiles()
    Const FOLDER_PATH As String = "G:\DATEN\" 'Anpassen !!! Backslash am Ende nicht löschen
    Dim astrFolders() As String, strFilename As String
    Dim ialngFolders As Long
    astrFolders = GetFolders(FOLDER_PATH)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFilename = Dir$(astrFolders(ialngFolders) & "*.xlsx")
        If strFilename <> vbNullString Then _
            Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:="C:\OUTPUT\" & strFilename)
    Next
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

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Edgar Höcker
Geschrieben am: 13.10.2020 07:52:38

Hallo Nepumuk,

funktioniert super! Macht genau das was ich will. Ich habe nur noch zwei Änderungen gemacht:
1. Aufruf der Funktion mit zwei Variablen (Ein.- und Ausgabeverzeichnis)
2. Änderung der INPUT und OUTPUT Werte in Varialen, die ich übergebe.

Hab vielen Dank!

Edgar

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Edgar Höcker
Geschrieben am: 13.10.2020 08:01:09

Nachdem ich dank Nepumuks Hilfe mein Problem lösen konnte setze ich noch einen drauf. Ihr seht, Dateiverarbeitung unter Excel VBA ist nicht wirklich mein Ding. Ich versuche aber immer alles, was mir als Lösung angeboten wird, auch zu verstehen.

Jetzt befinden sich alle Excel Dateien in meinem OUTPUT Ordner.
Im nächsten (und letzten) Schritt möchte ich nacheinander alle WB aufmachen, einen Blattschutz deaktivieren, eine Änderung auf dem WS vornehmen, Blattschutz wieder aktivieren und WB schließen

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Nepumuk
Geschrieben am: 13.10.2020 10:26:13

Hallo Edgar,

aufgrund mangelnder Angaben nur ein Beispiel:

Option Explicit

Public Sub Beispiel()
    
    Const FOLDER_PATH As String = "H:\" ' Anpassen !!!
    
    Dim strFilename As String
    Dim objWorkbook As Workbook
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    strFilename = Dir$(FOLDER_PATH & "*.xls*")
    
    Do Until strFilename = vbNullString
        
        Set objWorkbook = Workbooks.Open(Filename:=FOLDER_PATH & strFilename)
        
        With objWorkbook.Worksheets(1)
            
            Call .Unprotect(Password:="GEHEIM")
            
            .Cells(1, 1).Value = "Hallo"
            
            Call .Protect(Password:="GEHEIM")
            
        End With
        
        Call objWorkbook.Close(SaveChanges:=True)
        
        strFilename = Dir$
        
    Loop
    
    Set objWorkbook = Nothing
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Gruß
Nepumuk

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Edgar Höcker
Geschrieben am: 13.10.2020 16:18:08

Danke auch dafür. Habe mittlerweile viel gelesen und gesucht. Bin auch fündig geworden. Habe die Code-Schnippsel an meine Bedürfnisse angepasst. Hat zwar etwas gedauert und ist sicherlich auf etwas umständlich, aber es funktioniert.

Was wollte ich rreichen?
Nach dem ersten Step, der alle Unterordner nacheinander öffnet und die darin enthaltene .XLSX Datei in den Ausgangsordner schiebt sollte Step2 folgen.
Step2 nimmt nacheinander jede .XLSX Datei im Ausgangsordner, öffnet WS1 und löscht darin Zeile5. Dann wird WS3 geöffnet und die Zeilen 5-6 an das Ende von Zeile 1-2 verschoben.

Die :XLSX Dateien werden anschließend in QlikView geladen und analysiert.

nach oben  nach unten

Betrifft: AW: Dateien kopieren
von: Nepumuk
Geschrieben am: 13.10.2020 16:30:42

Hallo Edgar,

so ganz kann ich dir nicht folgen. Lade mal eine Mustermappe mit soll/ist hoch.

Gruß
Nepumuk