有搜索功能需要幫助編輯

Question

所以我有一段代碼，我已經寫了代碼的第一部分，是用指定的標題創建一個新的工作表。代碼的第二部分是爲了用某些信息填充該表。我遇到的問題是獲取正確的位信息進入正確的列。 我需要的代碼來搜索工作簿 之內的所有的工作表中的列G中的值9.1，如果該值被發現我需要它這在新的片材具有以下信息一起復制到柱B：

引擎F列的影響必須將同一行粘貼到名爲FHA 的工作表中的列C部分編號始終位於單元格J3中，它必須粘貼到列D中且始終相同 零件名稱始終位於C2中必須粘貼到列E並始終相同 來自列B的FM ID同一行必須粘貼到工作表中列F的標題爲FHA 故障模式& C列的原因必須將同一行粘貼到FHA​​ 01列中FMCN值從列N粘貼到H列在FHA

，因爲它代表我的代碼是

Sub createWSheetFHA() 
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "FHA" 

    Cells(1, 2) = "FHA TABLE" 
    Cells(2, 2) = "FHA Ref" 
    Cells(2, 3) = "Engine Effect" 
    Cells(2, 4) = "Part No" 
    Cells(2, 5) = "Part Name" 
    Cells(2, 6) = "FM I.D" 
    Cells(2, 7) = "Failure Mode & Cause" 
    Cells(2, 8) = "FMCM" 
    Cells(2, 9) = "PTR" 
    Cells(2, 10) = "ETR" 

    Range(Cells(2, 2), Cells(2, 10)).Font.Bold = True 
    Range(Cells(1, 2), Cells(1, 10)).MergeCells = True 
    Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True 

End Sub 
Sub Populate_FHA_Table_2() 
    Dim wks As Excel.Worksheet, i As Integer, n As Integer 
    Application.ScreenUpdating = False 
    Sheets("FHA").Range("A2:" & Columns.Count & ":" & Rows.Count).Delete 
    i = 1 
    For Each wks In ActiveWorkbook.Worksheets 
     If wks.Name <> "FHA" Then 
      wks.UsedRange.AutoFilter Field:=7, Criteria1:="9.1" 
      Sheets(i).Range(Sheets(i).Range("G1").Offset(1), Sheets(i).Range("B1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("C" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("F1").Offset(1), Sheets(i).Range("D1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("d" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("J1").Offset(1), Sheets(i).Range("E1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("e" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("C1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("E" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("B1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("F" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("C1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("G" & Rows.Count).End(xlUp) 
      Sheets(i).Range(Sheets(i).Range("N1").Offset(1), Sheets(i).Range("H1").End(xlDown)).Copy _ 
       Sheets("FHA").Range("H" & Rows.Count).End(xlUp) 
      wks.UsedRange.AutoFilter 
     End If 
    i = i + 1 
    Next 
    Application.ScreenUpdating = True 

End Sub 

Answer 1

您使用「爲每個周」然後通過訪問在代碼（的一些錯配例索引'我';他們可能不完全一致）

嘗試這樣的事情......

我在未嚴格需要一些動態流控制，但如果當你的頭在未來改變，它可能是添加使用這種形式更容易。

同樣我曾試圖在一些錯誤處理以及

Sub Create_FHA_Sheet() 
    Dim Headers() As String: Headers = _ 
    Split("FHA Ref,Engine Effect,Part No,Part Name,FM I.D,Failure Mode & Cause,FMCM,PTR,ETR", ",") 

    If Not WorksheetExists("FHA") Then Worksheets.Add().Name = "FHA" 
    Dim wsFHA As Worksheet: Set wsFHA = Sheets("FHA") 
    wsFHA.Move after:=Worksheets(Worksheets.Count) 
    wsFHA.Cells.Clear 

    Application.ScreenUpdating = False 

    With wsFHA 
     For i = 0 To UBound(Headers) 
      .Cells(2, i + 2) = Headers(i) 
      .Columns(i + 2).EntireColumn.AutoFit 
     Next i 
     .Cells(1, 2) = "FHA TABLE" 
     .Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).MergeCells = True 
     .Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).HorizontalAlignment = xlCenter 
     .Range(.Cells(1, 2), .Cells(2, UBound(Headers) + 2)).Font.Bold = True 
    End With 

    Dim RowCounter As Long: RowCounter = 3 
    Dim SearchTarget As String: SearchTarget = "9.1" 
    Dim SourceCell As Range, FirstAdr As String 

    If Worksheets.Count > 1 Then 
     For i = 1 To Worksheets.Count - 1 
     With Sheets(i) 
      Set SourceCell = .Columns(7).Find(SearchTarget, LookAt:=xlWhole) 
      If Not SourceCell Is Nothing Then 
       FirstAdr = SourceCell.Address 
       Do 
        wsFHA.Cells(RowCounter, 3).Value = .Cells(SourceCell.Row, 6).Value 
        wsFHA.Cells(RowCounter, 4).Value = .Cells(3, 10).Value 
        wsFHA.Cells(RowCounter, 5).Value = .Cells(2, 3).Value 
        wsFHA.Cells(RowCounter, 6).Value = .Cells(SourceCell.Row, 2).Value 
        wsFHA.Cells(RowCounter, 7).Value = .Cells(SourceCell.Row, 3).Value 
        wsFHA.Cells(RowCounter, 8).Value = .Cells(SourceCell.Row, 14).Value 
        Set SourceCell = .Columns(7).FindNext(SourceCell) 
        RowCounter = RowCounter + 1 
       Loop While Not SourceCell Is Nothing And SourceCell.Address <> FirstAdr 
      End If 
     End With 
     Next i 
    End If 
    Application.ScreenUpdating = True 
End Sub 

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean 
    On Error Resume Next 
    WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "") 
    On Error GoTo 0 
End Function