Folder contents Empty

[Kov4n]

Hi,
I've written a VBA to copy files from a list of directory over to a specific folder.
The code works fine and what I now need to do is add an IF statement for the VBA to move to the next folder when one folder is empty and copy any files in the next folder.
Any codes that will allow the VBA to do this?

 

[HongRu]

try this.

Sub test()
    myPath = "D:\T3\"
    myFileName = Dir(myPath)
    Do Until myFileName = ""
        myFileName = Dir()
    Loop
End Sub

 

[mmhill]

IF statement for the VBA to move to the next folder when one folder is empty and copy any files in the next folder.

There's a lot of ways to do this, depending on exactly what you want to so. The code @HongRu posted will loop and get all files in a folder. If you want to look in multiple folders, you have to change the my path variable.

You could put them in the code ...

Sub test()
Dim ayPath(1 To 2) As String, i%, myFileName$
    ayPath(1) = "C:\Users\Admin\"
    ayPath(2) = "C:\Users\Public\"
    For i = 1 To 2
        myFileName = Dir(ayPath(i))
        Do Until myFileName = ""
            Debug.Print myFileName
            myFileName = Dir()
        Loop
    Next i
End Sub

or put them on a spreadsheet ...

Sub test()
Dim ayPath(1 To 2) As String, i%, myFileName$
Dim c As Range
    Set c = Sheet9.Range("A1")'<<< Paths are in this column
    i = 0
    Do While c.Value <> ""
        myFileName = Dir(c)
        Do Until myFileName = ""
            Debug.Print myFileName
            myFileName = Dir()
        Loop
        i = i + 1
        Set c = c.Offset(i, 0)
    Loop
End Sub

If you want VBA to do the looking for you, you need a recursive file search that looks in folders and sub folder and subfolders of subfolders.
This macro listed 1050 files in 140 folders in about 1 second.

Option Explicit
Const iArrayIncrement% = 100
Dim objFS As Object, ayFiles(), i%

Sub ListFileVoudou()
Dim strFolder$, rngOutput As Range

    'PICK WHERE YOU WANT TO START. THIS MACRO WRITES A LIST TO A SREADSHEET
    strFolder = "C:\Users\skippy\Documents\"
    Set rngOutput = ActiveWorkbook.ActiveSheet.Range("A1")
    
    Set objFS = CreateObject("Scripting.FileSystemObject")
    ReDim ayFiles(1 To 3, 1 To iArrayIncrement)
    i = 0

    'LOOK THRU ALL FOLDER AND SUBFOLDERS
    psListIndividualFiles strFolder

    ReDim Preserve ayFiles(1 To 3, 1 To i)
    rngOutput.Resize(rowsize:=i, columnsize:=3) = Application.Transpose(ayFiles)

    Debug.Print "Finished: " & i & " files"
    Set rngOutput = Nothing
    Set objFS = Nothing
    Beep
End Sub

Private Sub psListIndividualFiles(ByVal strFolder$)
Dim oFile As Object, tmpName$, tmpExt%, oSubFldr As Object
    
    For Each oFile In objFS.GetFolder(strFolder).Files
       'DO STUFF WITH YOUR FILES IN HERE THIS GETS FILE NAMES TO PRINT LATER
            i = i + 1
            If i > UBound(ayFiles, 2) Then ReDim Preserve ayFiles(1 To 3, 1 To (UBound(ayFiles, 2) + iArrayIncrement))
            ayFiles(1, i) = strFolder
            tmpName = oFile.Name
                ayFiles(2, i) = tmpName
                tmpExt = InStrRev(tmpName, ".")
                If tmpExt > 0 Then ayFiles(3, i) = Mid(tmpName, tmpExt, 5)
    Next oFile

    For Each oSubFldr In objFS.GetFolder(strFolder).SubFolders
        psListIndividualFiles strFolder & "\" & oSubFldr.Name
    Next
    
End Sub

 

[Kov4n]

Thank you, I need a bit more understanding on the above code, below is the current vba

Sub ExtractChecklistData()

Dim FSO As Object
Dim SourcePath As String

Dim DestinationPath As String
Dim FileExtn As String

'Starters
SourcePath = Sheet4.Range("B2")
SourcePath2 = Sheet4.Range("B4")
SourcePath3 = Sheet4.Range("B6")
SourcePath4 = Sheet4.Range("B8")
SourcePath5 = Sheet4.Range("B10")
SourcePath6 = Sheet4.Range("B12")
SourcePath7 = Sheet4.Range("B14")
SourcePath8 = Sheet4.Range("B16")
SourcePath9 = Sheet4.Range("B18")
SourcePath10 = Sheet4.Range("B20")
SourcePath11 = Sheet4.Range("B22")
SourcePath12 = Sheet4.Range("B24")
SourcePath13 = Sheet4.Range("B26")
SourcePath14 = Sheet4.Range("B28")
SourcePath15 = Sheet4.Range("B30")

DestinationPath = "C:\Users\kov4n\OneDrive\Documents\Excel Templates\Management Reports\Data Extract Folder\"

FileExtn = "*.xlsx*"

Set FSO = CreateObject("scripting.filesystemobject")

FSO.CopyFile Source:=SourcePath & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath2 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath3 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath4 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath5 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath6 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath7 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath8 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath9 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath10 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath11 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath12 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath13 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath14 & FileExtn, Destination:=DestinationPath
FSO.CopyFile Source:=SourcePath15 & FileExtn, Destination:=DestinationPath

The user selects the month on the dashboard sheet and sheet4 holds the file path names which changes based on the selected month. The folders are already set up and each month the team will add files to the area they are working on. Some months, some areas would not have any work so the folder related to that area will not have any files.

Testing this brings up the error message 'run-time error 53 - file not found'
So it copies the first file into the assigned folder moves to the next file path and as it has no files it brings up the above error.
What I need is possible an IF statement that will move to the next folder path when a folder is empty...

Hope you can help further

 

[mmhill]

I think this is what you are after, with a little extra checking to make sure.

Sub ExtractChecklistData()
Dim FSO As Object, DestinationPath As String, FileExtn As String, i As Integer, SourcePath As String

    Set FSO = CreateObject("scripting.filesystemobject")
    
    DestinationPath = "C:\Users\kov4n\OneDrive\Documents\Excel Templates\Management Reports\Data Extract Folder\"
    FileExtn = "*.xlsx"

    If Not FSO.FolderExists(DestinationPath) Then MkDir (DestinationPath) 'Make sure destination folder exists, make it if it does not
    
    For i = 2 To 30 Step 2 'check every other cell between 2 and 30.
        SourcePath = Sheet4.Cells(i, 2) 'row i ,column B ... Get the source path
        If Not Right(SourcePath, 1) = "\" Then SourcePath = SourcePath & "\" 'make sure source path has a "\" at the end
        'If sourcepath folder exists and there are FileExtn type files in it, copy all FileExtn files to the Destination path
        'Overwite for Destination path = TRUE so if a file of teh same name already exists there, the new copied file prevails (and no error is created)
        If FSO.FolderExists(SourcePath) And Dir(SourcePath & FileExtn) <> "" Then FSO.CopyFile SourcePath & FileExtn, DestinationPath, True
    Next i
    
    Set FSO = Nothing
    
End Sub

 

[Kov4n]

I think this is what you are after, with a little extra checking to make sure.

Sub ExtractChecklistData()
Dim FSO As Object, DestinationPath As String, FileExtn As String, i As Integer, SourcePath As String

    Set FSO = CreateObject("scripting.filesystemobject")
   
    DestinationPath = "C:\Users\kov4n\OneDrive\Documents\Excel Templates\Management Reports\Data Extract Folder\"
    FileExtn = "*.xlsx"

    If Not FSO.FolderExists(DestinationPath) Then MkDir (DestinationPath) 'Make sure destination folder exists, make it if it does not
   
    For i = 2 To 30 Step 2 'check every other cell between 2 and 30.
        SourcePath = Sheet4.Cells(i, 2) 'row i ,column B ... Get the source path
        If Not Right(SourcePath, 1) = "\" Then SourcePath = SourcePath & "\" 'make sure source path has a "\" at the end
        'If sourcepath folder exists and there are FileExtn type files in it, copy all FileExtn files to the Destination path
        'Overwite for Destination path = TRUE so if a file of teh same name already exists there, the new copied file prevails (and no error is created)
        If FSO.FolderExists(SourcePath) And Dir(SourcePath & FileExtn) <> "" Then FSO.CopyFile SourcePath & FileExtn, DestinationPath, True
    Next i
   
    Set FSO = Nothing
   
End Sub

Thank you for trying but was not able to configure the above to make it work.
Instead I have added 'On Error Resume Next' command which solves the problem