vba 宏循环遍历文件但无法遍历工作表

Question

我创建了一个 vba 宏，目的是： 1）一个一个打开文件夹中的每个文件 2）循环遍历每个工作表，取消保护每个工作表，查看顶行是否为空白（如果是则删除）并删除有问题的列。 3) 将文件另存为 xlsx。

到目前为止，我已经设法让它遍历每个文件，但无法遍历工作表。我以前能够让它对每个工作簿中的最后一个活动工作表进行更改，但现在它似乎跳过了每个工作表。

知道为什么吗？

Sub LoopThroughFiles()

    FolderName = ThisWorkbook.Path & "\Source Data\"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.xls*")

    'loop through the files
    Do While Len(Fname)

        With Workbooks.Open(FolderName & Fname)
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook
    Dim ws As Worksheet


Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

'Unshare Workbook
If ActiveWorkbook.MultiUserEditing Then
    ActiveWorkbook.ExclusiveAccess
End If

'Unprotect Workbook
ActiveWorkbook.Unprotect "pa55word"


For Each ws In ThisWorkbook.Worksheets

'Unprotect Worksheet
ws.Unprotect "pa55word"

'Unhide Columns and Rows
            ws.Cells.EntireColumn.Hidden = False
            ws.Cells.EntireRow.Hidden = False


 'Delete Blank top Row
 Set MR = ws.Range("A1:C1")
 For Each cell In MR
 If cell.Value = "" Then cell.EntireRow.Delete
 Next

  'Delete annoying Column
 Set MR = ws.Range("A1:BZ1")
 For Each cell In MR
 If cell.Value = "a2a" Then cell.EntireColumn.Delete
 Next

 'Remove Filter

 If ws.AutoFilterMode Then
 ws.ShowAllData
 ws.AutoFilterMode = False
 End If

 Next ws


ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Cleansed Data\" & Replace(Replace(ActiveWorkbook.Name, ".xlsx", ""), ".xls", "") & ".xlsx", FileFormat:=51
ActiveWorkbook.Close

        End With

        ' go to the next file in the folder
        Fname = Dir

    Loop



End Sub

Answer 1

您正在使用ActiveSheet 在循环中取消保护。

改成这个：

 For Each ws In ThisWorkbook.Worksheets
                'Unprotect Worksheet
                ws.Unprotect "pa55word" 'instead of ActiveSheet.Unprotect ~

否则它会受到保护，您无法进行更改。一般来说，避免使用ActiceCell、ActiveSheet 等 - How to avoid using Select in Excel VBA

此外，像这样设置MR 范围：

'Delete Blank top Row
Set MR = ws.Range("A1:C1")
For Each cell In MR
    If cell.Value = "" Then cell.EntireRow.Delete
Next

'Delete annoying Column
Set MR = ws.Range("A1:BZ1")
For Each cell In MR
    If cell.Value = "2a2" Then cell.EntireColumn.Delete
Next

在设置范围时，您必须参考 ws 父级。否则它需要ActiveSheet。

---

这里也是：

 If ws.AutoFilterMode Then
     ws.ShowAllData
     ws.AutoFilterMode = False
 End If

Answer 2

始终是 Excel.Object、Workbook.Object、Worksheet.Object 和 Range.Object；共 4 个对象。请查看此链接。

http://www.excelfunctions.net/Excel-Objects.html

另外，请参阅此链接。

http://www.excel-easy.com/vba/examples/loop-through-books-sheets.html

所以，现在有了新的教育，你已经准备好做实际的工作了。

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