Folder contents Empty

Kov4n

New Member
Joined
Nov 21, 2022
Messages
11
Office Version
  1. 365
Platform
  1. Windows
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?
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
try this.
VBA Code:
Sub test()
    myPath = "D:\T3\"
    myFileName = Dir(myPath)
    Do Until myFileName = ""
        myFileName = Dir()
    Loop
End Sub
 
Upvote 0
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 ...
VBA 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 ...
VBA Code:
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.
VBA Code:
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
 
Upvote 0
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
 
Upvote 0
I think this is what you are after, with a little extra checking to make sure.

VBA Code:
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
 
Upvote 0
I think this is what you are after, with a little extra checking to make sure.

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,315
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top