Question

我使用宏来更改计算机上给定文件夹中的所有工作簿。我们的想法是对文件夹中每个工作簿的每个工作表进行更改。

活动顺序：

1）打开用户选择的文件夹中的每个Excel文件

2）在工作簿中的每个工作表上执行任务

3）保存文件

4）关闭工作簿

然而，宏似乎并没有起作用。问题似乎来自Selection.AutoFilter。

我对VBA仍然很陌生，所以任何帮助或建议都会受到高度赞赏。

 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

Answer 1

你应该这样试试。

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循环遍历文件夹中所有工作簿中的所有工作表

1 个答案: