Я не могу запустить макрос VBA на всех книгах внутри папки

Question

Я только начал работать с VBA.

У меня есть код VBA, который подсчитывает количество слов в файле excel. Работает нормально.

Я хочу запустить этот макрос VBA для всех файлов, которые у меня есть в указанной папке c.

Не могли бы вы мне помочь?

Мой код ниже: Я получаю правильные значения только для файла, из которого я запустил макрос. Для остальных файлов полученные результаты неверны

Sub LoopThroughFiles()
        Dim xFd As FileDialog
        Dim xFdItem As Variant
        Dim xFileName As String
        Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
        If xFd.Show = -1 Then
            xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
            xFileName = Dir(xFdItem & "*.xls*")
            Do While xFileName <> ""
                With Workbooks.Open(xFdItem & xFileName)

    Dim wordList As New Collection
    Dim keyList As New Collection
    Dim c
    Worksheets("Sheet1").Activate
    Dim RangeToCheck As Range
    Set RangeToCheck = Range("A1:A1000")
    For Each c In RangeToCheck
        Dim words As Variant
        words = Split(c, " ") 
        For Each w In words
            Dim temp
            temp = -1
            On Error Resume Next
            temp = wordList(w)
            On Error GoTo 0
            If temp = -1 Then
                wordList.Add 1, Key:=w
                keyList.Add w, Key:=w
            Else
                wordList.Remove (w)
                keyList.Remove (w)
                wordList.Add temp + 1, w
                keyList.Add w, Key:=w
            End If
        Next w
    Next c
    Dim x
    Dim k
    k = 1
    For x = 1 To wordList.Count
        With Sheets("Sheet1")
            .Cells(k, "E").Value = keyList(x)  
            .Cells(k, "F").Value = wordList(x) 
           k = k + 1
            End If
        End With
    Next x
                End With
                xFileName = Dir
            Loop
        End If
    End Sub

Answer 1

Попробуйте это

Public Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    xFd.AllowMultiSelect = False
    If xFd.Show <> -1 Then
        MsgBox "No Folder selected":        Exit Sub
    End If
    Dim Folder As String: Folder = xFd.SelectedItems(1) & "\"
    Dim Files
    Files = Dir(Folder & "*.xls*")
    Dim Xls As String
    On Error Resume Next

    Dim CrWB As Workbook, CrSheet As Worksheet
    Dim ClnW As New Collection, ClnC As New Collection
    Dim Cols As Integer: Cols = 1
    Do While Files <> ""
        Xls = Replace(Folder & Files, "\\", "\")
        Set CrWB = Application.Workbooks.Open(Xls, , True)
        Set CrSheet = CrWB.Sheets("Sheet1")
        If Err.Number > 0 Then
            MsgBox "Can't open File " & Xls & vbCrLf & Err.Description
            Err.Clear
            GoTo 1
        End If
        Dim c As Range
        Set ClnW = New Collection: Set ClnC = New Collection
        For Each c In CrSheet.Range("A1:A1000")
            If c.Value <> "" Then
                Words = Split(CStr(c.Value), " ", , vbTextCompare)
                For Each s In Words
                    Err.Clear
                    tmp = ClnW(s)
                    If Err.Number > 0 Then
                        ClnW.Add Item:=s, Key:=s
                        ClnC.Add Item:=1, Key:=s
                    Else
                        x = ClnC(s) + 1
                        ClnC.Remove s
                        ClnC.Add Item:=x, Key:=s
                    End If
                Next
            End If
        Next

        Set CrSheet = ThisWorkbook.Sheets("Sheet1")
        With CrSheet
            .Cells(1, Cols).Value = Files
            .Cells(2, Cols).Value = "Word"
            .Cells(2, Cols + 1).Value = "Occurance"
            .Range(.Cells(1, Cols), .Cells(1, Cols + 1)).Merge
            Dim I As Integer: I = 3
            For Each s In ClnW
                .Cells(I, Cols).Value = s
                .Cells(I, Cols + 1).Value = ClnC(s)
                I = I + 1
            Next
        End With
        Cols = Cols + 2
1
        CrWB.Close False
        Files = Dir()
        Err.Clear
    Loop
End Sub