Excel Forum

Code: Select all

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet
    
    Set ws = Sheets("Path")
    ws.Range("a1 : a5000").ClearContents
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder("C:\Users\Lenovo\Desktop\PATH")
    
    colFolders.Add oFolder
    
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1
    
        For Each oFile In oFolder.files
            If Right(oFile, 7) = ".SLDDRW" Then
                ws.Cells(i + 1, 1) = oFolder.Path
                ws.Cells(i + 1, 2) = oFile.Name
                i = i + 1
            End If
        Next oFile


        For Each sf In oFolder.SubFolders
            colFolders.Add sf
        Next sf
    Loop

Code: Select all

'Other code
For Each oFile In oFolder.files
'   If Right(oFile, 7) = ".SLDDRW" Then
    If InStr(oFile, "REPLACEMENT") Then
        ws.Cells(i + 1, 1) = oFolder.Path
        ws.Cells(i + 1, 2) = oFile.Name
        i = i + 1
    End If
Next oFile
'Other code

Code: Select all

'Other code
For Each oFile In oFolder.Files
    If InStr(oFile, "REPLACEMENT") Then
       If Right(oFile, 7) = ".SLDDRW" Then
            ws.Cells(i + 1, 1) = oFolder.Path
            ws.Cells(i + 1, 2) = oFile.Name
            i = i + 1
       End If
    End If
Next oFile
'Other code

Code: Select all

Dim i As Long

Sub main()
    i = 0
    Call getpath2("C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 3000")
    Call getpath2("C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 4000")
End Sub

Sub getpath2(f As String)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
'    Dim i As Integer, colFolders As New Collection, ws As Worksheet
    Dim colFolders As New Collection, ws As Worksheet
    Set ws = Sheets("Path")
'    ws.Range("a1 : a5000").ClearContents
    Set oFSO = CreateObject("Scripting.FileSystemObject")
'    Set oFolder = oFSO.GetFolder("C:\Users\Lenovo\Desktop\PATH")
    Set oFolder = oFSO.GetFolder(f)
    
    
    colFolders.Add oFolder
    
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1
    
        For Each oFile In oFolder.Files
            If InStr(oFile, "REPLACEMENT") Then
               If Right(oFile, 7) = ".SLDDRW" Then
                    ws.Cells(i + 1, 1) = oFolder.Path
                    ws.Cells(i + 1, 2) = oFile.Name
                    i = i + 1
               End If
            End If
        Next oFile

'        For Each sf In oFolder.SubFolders
'            colFolders.Add sf
'        Next sf
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

End Sub