VBA – 通过工作簿中的多个工作表进行循环
我有代码循环通过一个文件夹来打开文件，并从名称“持有人”和“切割工具”的列通过search标题，并打印所有的信息在该标题下的一个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:\Users\trembos\Documents\TDS\progress\2\" '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
当您使用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方法。