通过文件扩展名循环，excel vba

Question

I am using an Array of File extensions and looping through a folder of workbooks. The code is naming Sheet(1).name="MyName"

I notice that even though "*.xlsm" is not in the array, it is still opening and naming the sheet.

Here's the code. Can anybody see if they get the same problem and are able to solve it.

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range
    Dim fExt, ext
    Set Wb = ThisWorkbook
    'change the address to suite
    MyDir = "C:\TestWorkBookLoop\"
    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    fExt = Array("*.xlsx", "*.xls")    'file extensions, set the file extensions of the files to move

    For Each ext In fExt    'loop through file extensions
        MyFile = Dir(MyDir & ext)


        Do While MyFile <> ""
            Workbooks.Open (MyFile)
            Sheets(1).Name = "MySheet"

            With ActiveWorkbook
                .Save
                .Close
            End With

            MyFile = Dir()
        Loop
    Next ext
End Sub

Answer 1

The legacy short (8.3) file name for HELLO.ABCD would look something like ABCDEF~1.ABC - see the extension is truncated to 3 characters.

In your case GET.XLSM would be ABCDEF~1.XLS and this 8.3 form is also matched by the Win32 API FindFirstFile (which is what Dir() calls under the hood) when you specify *.XLS

Just filter out the exceptions in you loop with

If Not UCase$(MyFile) Like "*.XLSM" Then 
    ....

Answer 2

While Alex has solved your query, I have updated your code below to

• ensure it handles all excel file types
• handle the sheet name already existing (else your code will error out)
• cleanup and properly use variables

• restore events at close

   Sub LoopThroughFolder() Dim Wb As Workbook Dim MyFile As String Dim MyDir As String Dim StrFile As String MyDir = "C:\\temp\\" ChDir MyDir With Application .ScreenUpdating = False .DisplayAlerts = False End With StrFile = "*.xls*" MyFile = Dir(MyDir & StrFile) Do While Len(MyFile) > 0 If MyFile Like "*.xlsx" Or MyFile Like "*.xlx" Then Set Wb = Workbooks.Open(MyFile) On Error Resume Next Wb.Sheets(1).Name = "MySheet" On Error GoTo 0 Wb.Save Wb.Close False End If MyFile = Dir() Loop With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub