搜索字符串並將單元格向下複製兩行

Question

我有一個很多工作表，我需要遍歷每個工作表並將特定的一行數據複製到主工作表。我爲這部分代碼工作正常 - 我想要複製到主表的數據將始終在第17行中找到。但是，我想要開始複製我的數據的行17中的位置（列）不同。我需要在標題行（第15行）中搜索字符串「Expenses」，並且在定位此單元格後向下移動兩行到第17行，並從「Expenses」字詞所在的列開始複製該行數據的其餘部分找到。目前，我的代碼只是複製整行數據。任何人都可以幫助我修改此代碼來搜索字符串，然後使用該位置來複制數據？

Sub MasterSheet() 

Dim Sht As Worksheet 

Sheets("Master").Select 
Rows("2:" & Rows.Count).ClearContents 
Application.ScreenUpdating = False 
For Each Sht In ActiveWorkbook.Worksheets 
    If Sht.Name <> "Master" Then 
     Sht.Select 
     Range("A:A").Insert 
     Range("A17").Formula = "=Mid(Cell(""filename"",B1),Find(""]"",Cell(""filename""))+1,255)" 
     Range("A17").Copy 
     Range("A17").PasteSpecial Paste:=xlPasteValues 
     Range("A17:T17").Copy 
     Sheets("Master").Select 
     Range("A65536").End(xlUp).Offset(1, 0).Select 
     ActiveSheet.Paste 
     Sht.Select 
     Range("A:A").Delete 
    Else 
End If 

Next Sht 
Sheets("Master").Select 
Rows("2:" & Rows.Count).ClearFormats 
Application.ScreenUpdating = True 
End Sub 

Answer 1

Sub MasterSheet() 

    Dim Sht As Worksheet, f As Range, shtM As Worksheet 
    Dim wb As Workbook 

    Set wb = ActiveWorkbook 
    Set shtM = wb.Sheets("Master") 
    shtM.Rows("2:" & Rows.Count).ClearContents 

    Application.ScreenUpdating = False 
    For Each Sht In ActiveWorkbook.Worksheets 

     If Sht.Name <> shtM.Name Then 

      'find the header 
      Set f = Sht.Rows(15).Find("Expenses", , xlValues, xlWhole) 

      'if the header was found... 
      If Not f Is Nothing Then 

       With shtM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 

        .Value = Sht.Name 'sheet name in ColA 
        'copy the values two rows down from f 
        'change the 100 to suit 
        .Offset(0, 1).Resize(1, 100).Value = _ 
           f.Offset(2, 0).Resize(1, 100).Value 
       End With 
      End If 

     End If 'checking this sheet 

    Next Sht 

    shtM.Rows("2:" & Rows.Count).ClearFormats 
    shtM.Select 

    Application.ScreenUpdating = True 
End Sub