本文介绍了Excel VBA遍历文件夹内所有工作簿中的所有工作表的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!
问题描述
我正在使用宏对计算机上给定文件夹中的所有工作簿进行更改.这个想法是在文件夹中每个工作簿的每个工作表上进行更改.
I'm using a macro to make changes to all workbooks in a given folder on my computer. The idea is that the changes are made on each sheet of each workbook in the folder.
事件顺序:
-
打开用户选择的文件夹中的每个Excel文件
Opens each Excel file within the user-selected folder
在工作簿的每个工作表上执行任务
Performs a task on each sheet in the workbook
保存文件
关闭工作簿
但是,宏似乎不起作用.问题似乎是由Selection.AutoFilter
引起的.
However the macro doesn't seem to be working. The problem seems to be arising from Selection.AutoFilter
.
我对VBA还是很陌生,因此我们将不胜感激任何帮助或建议.
I am still very new to VBA, so any help or advice would be highly appreciated.
Sub LoopAllExcelFilesInFolder()
'OBJECTIVE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim Current As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Task: For each worksheet, delete the first column, make A1 bold, and filter and remove all rows in column A that do not contain anything
For Each Current In wb.Worksheets
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Selection.Font.Bold = True
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$5000").AutoFilter Field:=1, Criteria1:="="
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveSheet.ShowAllData
Range("A1").Select
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
推荐答案
您应该这样尝试.
Sub Example()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
On Error Resume Next
With mybook.Worksheets(1)
If .ProtectContents = False Then
.Range("A1").Value = "My New Header"
Else
ErrorYes = True
End If
End With
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
https://www.rondebruin.nl/win/s3/win010.htm
这篇关于Excel VBA遍历文件夹内所有工作簿中的所有工作表的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!