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

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

2 个答案: