Dateien kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Dateien kopieren

12.10.2020 09:21:36

Nepumuk

AW: Dateien kopieren

13.10.2020 07:52:38

Edgar

AW: Dateien kopieren

13.10.2020 08:01:09

Edgar

AW: Dateien kopieren

13.10.2020 10:26:13

Nepumuk

AW: Dateien kopieren

13.10.2020 16:18:08

Edgar

AW: Dateien kopieren

13.10.2020 16:30:42

Nepumuk

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

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

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

51 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

51 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread