[英]I can't run VBA Macro on all workbooks inside a folder
我刚开始使用 VBA。
我有一个 VBA 代码,用于计算 excel 文件中单词出现的次数。 它工作正常。
我想在特定文件夹中的所有文件上运行这个 VBA 宏。
你能帮帮我吗?
我的代码如下:我只为运行宏的文件获取值。 对于文件的rest,得到的结果是错误的
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
尝试这个
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.