VBA - 循环访问工作簿中的多个工作表

Question

我有代码，可以循环访问文件夹以打开文件并从名称"HOLDER"和"CUT TOOL"的列中获取重要信息通过搜索标题并将该标题下的所有信息打印到一个 excel 文档 masterfile 中。它还将文件名打印到第 4 列，将"工具数据表"的名称打印到第 1 列。

我有代码集

'(1)
    For Each objFile In objFolder.Files
        With WB
'(2)
            For Each ws In .Worksheets
        ...
        ''''''''''''''''code for all info I need to get from opened file'''''''''''''''''
        ...
            Next ws
'(6)
        End With
    Next objFile

问题是它会遍历我在Workbook中的ws数量，但它不会切换到下一个工作表。例如，如果打开文件中的第一个工作表的值为 1 2 3，第二个工作表的值为 5 7，第三个工作表的值为 8 9 10，它将打印到我的主文件 1 2 3 然后 1 2 3 然后 1 2 3。因此，它只打开第一个并循环遍历我在打开的文件中的工作表数量，而不是通过工作表本身。对此进行故障排除的任何想法？我被卡住了。

完整代码

Option Explicit
Sub LoopThroughDirectory()
    Const ROW_HEADER As Long = 10
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim dict As Object
    Dim MyFolder As String
    Dim f As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer
    Dim Height As Integer
    Dim FinalRow As Long
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, hc4 As Range, d As Range
    Dim TDS As Range
    Dim hc12 As Range
    Dim n As Range
    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")
    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False
    'location of the folder in which the desired TDS files are
    MyFolder = "C:UserstrembosDocumentsTDSprogress2"
    'find the headers on the sheet
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")
    Set hc4 = HeaderCell(StartSht.Range("A1"), "TOOLING DATA SHEET (TDS):")
    'create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'get the folder object
    Set objFolder = objFSO.GetFolder(MyFolder)
    i = 2
    'loop through directory file and print names
'(1)
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
            'Open folder and file name, do not update links
            Set WB = Workbooks.Open(FileName:=MyFolder & objFile.Name, UpdateLinks:=0)
            Set ws = WB.ActiveSheet
            With WB
                For Each ws In .Worksheets

'            If Not Range("A1:A24").Find(What:="TOOL NUM", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
'                Set n = ws.Cells(Rows.count, 1).End(xlUp)
'(3)
                'find CUTTING TOOL on the source sheet'
                If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
'                Set n = ws.Cells(Rows.count, 1).End(xlUp)
'                Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
'                If Not hc Is Nothing Then
                    Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
                    If dict.count > 0 Then
                    'add the values to the master list, column 3
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
                    End If
                Else ' find TOOL CUTTER on sheet
                    'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOLS PRESENT"
                    If Not Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                    Set hc = Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues)
                        Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
                        If dict.count > 0 Then
                        'add the values to the master list, column 3
                            Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                            d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                        Else
                            'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
                        End If
                    End If
                End If
'(4)
                'find HOLDER on the source sheet

                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then
'                If Not Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
'                    Set hc3 = Range("A1:M15").Find(What:="HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
                        Set dict = GetValues(hc3.Offset(1, 0))
                        'If InStr(ROW_HEADER, "HOLDER") <> "" Then
                        If dict.count > 0 Then
                        'add the values to the master list, column 2
                            Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                            d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    Else
                        'StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0) = "none"
                    End If
                ' find "TOOL HOLDER" on sheet
                ElseIf Not Range("A1:M15").Find(What:="TOOL HOLDER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                    Set hc = Range("A1:M15").Find(What:="TOOL HOLDER", LookAt:=xlWhole, LookIn:=xlValues)
                        Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
                        If dict.count > 0 Then
                        'add the values to the master list, column 3
                            Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                            d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                        Else
                            'StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "2"
                        End If
                'End If
                Else
                    If hc3 Is Nothing Then
                        StartSht.Range(StartSht.Cells(i, 2), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO HOLDERS PRESENT!"
                    End If
                End If
'(5)
                    'print the file name to Column 4
                    StartSht.Cells(i, 4) = objFile.Name
                    With ws
                    'Print TDS name by searching for header
                        If Not Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                            Set TDS = Range("A1:K1").Find(What:="TOOLING DATA SHEET (TDS):", LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1)
                            StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = TDS
                        Else
                            'print the file name wihtout the extension
                            StartSht.Range(StartSht.Cells(i, 1), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = GetFilenameWithoutExtension(objFile.Name)
                        End If
                        i = GetLastRowInSheet(StartSht) + 1
                    End With
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
'(7)
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1 'brings the viewer to the top of the masterfile
End Sub
'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object
    Dim rng As Range, c As Range
    Dim v
    Dim spl As Variant
    Set dict = CreateObject("scripting.dictionary")
    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
            If Not dict.exists(v) Then
                If Len(v) > 0 Then
            'exclude any info after ";"
            If Not IsMissing(vSplit) Then
                spl = Split(v, ";")
                v = spl(0)
            End If
            'exclude any info after ","
            If Not IsMissing(vSplit) Then
                spl = Split(v, ",")
                v = spl(0)
            End If
        End If
        dict.Add c.Address, v
    End If
        If Len(v) = 0 Then
            v = "none"
        End If
'        If Len(v) = "" Then
'            v = ""
'        End If
    Next c
    Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
    Dim rv As Range, c As Range
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
        'copy cell value if it contains some string "holder" or "cutting tool"
        If Trim(c.Value) = sHeader Then
        'If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function
'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function
'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          LookAt:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function
'(12)
'get the file name without the extension
Function GetFilenameWithoutExtension(ByVal FileName)
  Dim Result, i
  Result = FileName
  i = InStrRev(FileName, ".")
  If (i > 0) Then
    Result = Mid(FileName, 1, i - 1)
  End If
  GetFilenameWithoutExtension = Result
End Function

Answer 1

使用 Range 或 Cells 方法时，请始终完全限定工作表和工作簿。所以你的代码看起来像这样：

        With WB
            For Each ws In .Worksheets
                'find CUTTING TOOL on the source sheet'
                If Not Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                Set hc = Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)

最后两行不说明区域所属的工作表。因此，请改为使用：

        With WB
            For Each ws In .Worksheets
                'find CUTTING TOOL on the source sheet'
                If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
                    Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)

实际上，您可以进一步细化这一点，因为您不需要两次使用 Find 方法。

        With WB
            For Each ws In .Worksheets
                'find CUTTING TOOL on the source sheet'
                Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
                If Not (hc Is Nothing) Then

在代码中的其他位置，您需要将工作表限定符添加到 Range 和 Cells 方法。