VBA - цикл через несколько рабочих листов в рабочей книге

Question

У меня есть код, который просматривает папку для открытия файлов и получает важную информацию из столбцов имен «HOLDER» и «CUTTING 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 

Проблема в том, что это будет цикл через номер ws У меня есть в Workbook, но он не переключится на следующий рабочий лист. Например, если первый лист в открытом файле имеет значения 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 

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 методов.