Extract .xls or .xlsm files within a folder and sub-folder

[howard]

I have a macro to extract excel files from c:\PULL as well as sub-folder within pull that are .xls or .xlsm


The .xls or being extracted but not the .xlsm if there is an xlsm file


Kindly amend my code below

 Sub List_Man_Acc_FileNames()

Sheets("file names").Range("A1:C150").ClearContents
Application.ScreenUpdating = False
Sheets("file names").Range("A1:C1").Value = Array("File Name", "Created", "Last Modified")

LoopController ("C:\pull")
Sheets("file names").Columns.AutoFit

End Sub

Private Sub LoopController(sSourceFolder As String)
'This will loop into itself, first processing the files in the folder
'then looping into each subfolder deeper and deeper until all folders processed
Dim Fldr As Object, FL As Object, SubFldr As Object

    Call ListFilesinFolder(sSourceFolder & Application.PathSeparator)

    Set Fldr = CreateObject("Scripting.FileSystemObject").GetFolder(sSourceFolder)
    For Each SubFldr In Fldr.SubFolders
        LoopController SubFldr.path
    Next

End Sub

Sub ListFilesinFolder(MyPath As String)
Dim FSO As Object, f As Object, FLD As Object, NR As Long

NR = Sheets("file names").Range("A" & Rows.Count).End(xlUp).Row
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLD = FSO.GetFolder(MyPath).Files

For Each f In FLD
    If InStr(f.Name, "ACCNTS(P)") > 0 And Right(f.Name, 4) = ".xls" Or InStr(f.Name, "ACCNTS(P)") > 0 And Right(f.Name, 4) = ".xlsm" Then
        NR = NR + 1
        Sheets("file names").Range("A" & NR).Value = f.Name
        Sheets("file names").Range("B" & NR).Value = f.DateCreated
        On Error Resume Next
        Sheets("file names").Range("C" & NR).Value = f.DateLastModified
        On Error GoTo 0
    End If
Next f

End Sub

Your assistance is most appreciated

 

[John_w]

Look at 5 characters for ".xlsm" and maybe LCase too:

LCase(Right(f.Name, 5)) = ".xlsm"

 

[howard]

Thanks for your help