有搜索功能需要帮助编辑

mnatus 发布于 5 天前 excel 最后更新 5 天前 0 浏览

所以我有一段代码,我写了代码的第一部分是创建一个指定标题的新工作表。代码的第二部分是为了用某些信息填充该表。我遇到的问题是获取正确的位信息进入正确的列。  我需要代码在工作簿中的所有工作表中搜索列G中的值9.1  如果找到该值,我需要将它复制到新工作表中的第b列以及以下信息: F列的引擎效果必须将同一行粘贴到名为FHA的工作表中的C列  部件号始终位于Cell J3中,必须将其粘贴到D列中并始终保持不变  零件名称始终位于C2中,必须粘贴到E列中并始终保持不变  来自列B同一行的FM ID必须粘贴到名为FHA的工作表中的F列  失败模式& C列的原因必须将同一行粘贴到FHA​​的G列  从列N粘贴到列H的FMCN值在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
已邀请:

bipsam

赞同来自:

您的代码中存在一些不匹配(示例使用'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