有searchfunction需要帮助编辑
所以我有一个代码我已经写了第一部分的代码是创build一个新的工作表与指定的标题。 代码的第二部分是为了用某些信息填充该表。 我遇到的问题是获取正确的位信息进入正确的列。 我需要代码来search工作簿中的所有工作表中的列G中的值9.1如果find该值我需要它复制到新工作表中的列b以及以下信息：
F列中的引擎效应必须将同一行粘贴到名为FHA的工作表中的C列部件号始终位于单元格J3中，必须将其粘贴到D列中并始终保持相同部分名称始终位于C2中，必须将其粘贴到列E始终与列B相同FM ID相同的行必须粘贴到工作表F列中的列F FHA列F中的失败模式和原因必须将同一行粘贴到FHA中的G列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 ID" 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 你的代码中有一些不匹配的地方（例如使用'for each wk'然后通过索引'i'访问;它们可能不一定匹配）
尝试这样的事情…
我已经添加了一些不是严格需要的dynamicstream量控制，但是如果将来您的标题更改时，可能会更容易以此forms进行。
同样，我也尝试添加一些error handling
Sub Create_FHA_Sheet() Dim Headers() As String: Headers = _ Split("FHA Ref,Engine Effect,Part No,Part Name,FM ID,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