如何循环浏览文件夹中所有工作簿中的所有工作表 [英] How to loop through all sheets in all workbooks within a folder

问题描述

我使用宏在计算机上给定文件夹中的每个工作簿的每一页上进行更改.

I use a macro to make changes on each sheet of each workbook in a given folder on my computer.

事件顺序:

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

1. Open each Excel file within the user-selected folder

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

Perform a task on each sheet in the workbook

保存文件

关闭工作簿

宏不起作用.该问题似乎是由 Selection.AutoFilter 引起的.

The macro doesn't work. The problem seems to be arising from Selection.AutoFilter.

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

这篇关于如何循环浏览文件夹中所有工作簿中的所有工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！