有搜索功能需要帮助编辑

Question

所以我有一个代码，我已经编写了代码的第一部分是创建一个带有指定标题的新工作表。代码的第二部分旨在用某些信息填充该表。我遇到的问题是获取正确的信息位以进入正确的列。 我需要代码在工作簿内所有工作表的 G 列中搜索值 9.1 如果找到该值，我需要它将其与以下信息一起复制到新工作表中的 b 列：

来自 F 列的引擎效果 同一行必须粘贴到标题为 FHA 的工作表中的 C 列 部件号始终位于单元格 J3 中，必须粘贴到 D 列中并且始终相同 部件名称始终位于 C2 中，必须粘贴到 E 列中并且始终相同 B 列中的 FM ID 同一行必须粘贴到标题为 FHA 的工作表中的 F 列 C 列的故障模式和原因 必须将同一行粘贴到 FHA 中的 G 列 在 FHA 中粘贴到 H 列的 N 列的 FMCN 值

就目前而言，我拥有的代码是

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

你的代码中有一些不匹配（例如，使用"for each wk"然后通过索引"i"访问;它们不一定匹配）

试试这样的事情...

我添加了一些动态流控制，这不是绝对需要的，但是如果您的标头将来发生变化，则以这种形式使用它可能会更容易。

同样，我也尝试添加一些错误处理

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