有搜索功能需要帮助编辑 [英] Have search function need help editing

问题描述

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

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

由于代码I已经是

  Sub createWSheetFHA（）
 Worksheets.Add（After：= Worksheets（Worksheets.Count） =FHA
 
单元格（1，2）=FHA TABLE
单元格（2，2）=FHA参考
单元格（2，3）=引擎效果
单元格（2，4）=零件号
单元格（2，5）=零件名称
单元格（2,6）=FM ID
单元格（2,7）=失败模式和原因
单元格（2,8）=FMCM
单元格（2,9）=PTR
单元格2，10）=ETR
 
范围（单元格（2，2），单元格（2，10））Font.Bold = True 
范围（单元格（1,2） ，Cells（1，10））MergeCells = True 
范围（单元格（1，2），单元格（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 
她ets（FHA）。范围（A2：& Columns.Count& ：& Rows.Count）.Delete 
 i = 1 
对于每个wks在ActiveWorkbook.Worksheets 
如果wks.Name<> FHA然后
 wks.UsedRange.AutoFilter字段：= 7，Criteria1：=9.1
表格（i）.Range（Sheets（i）.Range（G1）。Offset（1 ），Sheets（i）.Range（B1）。End（xlDown））。Copy _ 
 Sheets（FHA）。Range（C& Rows.Count）.End（xlUp）
表（i）.Range（Sheets（i）.Range（F1）。Offset（1），Sheets（i）.Range（D1）。End（xlDown））。Copy _ 
（FHA）。范围（d& Rows.Count）.End（xlUp）
表格（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 _ 
（FHA）范围（E& Rows.Count）.End（xlUp）
表（i）.Range（Sheets（i）.Range（B1）。Offset（1 ），Sheets（i）.Range（H1）。End（xlDown））。Copy _ 
 Sheets（FHA）。Range（F& Rows.Count）.End（xlUp）
 （I）.Range（Sheets（i）.Range（C1）。Offset（1），Sheets（i）.Range（H1）。End（xlDown））。Copy _ 
 Sheets FHA）。范围（G& Rows.Count）.End（xlUp）
 Sheets（i）.Range（Sheets（i）.Range（N1）。Offset（1），Sheets（i）.Range（H1）。 （xlDown））复制_ 
表格（FHA）。范围（H& Rows.Count）.End（xlUp）
 wks.UsedRange.AutoFilter 
 End If 
i = i + 1 
下一个
 Application.ScreenUpdating = True 
 
 End Sub 
  

解决方案

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

尝试这样的东西...

我已经添加了一些动态流量控制严格需要，但如果将来您的标题更改，则可能会更容易。

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

  Sub Create_FHA_Sheet（）
 Dim Headers（）As String：Headers = _ 
 Split（ FHA参考，发动机效应，零件号，部件名称，FM I.D，故障模式&原因，FMCM，PTR，ETR，，）
 
如果不是WorksheetExists（FHA）Then Worksheets.Add（）。Name =FHA
 Dim wsFHA As Worksheet：设置wsFHA = Sheets（FHA）
 wsFHA.Move after：= Worksheets（Worksheets.Count）
 wsFHA.Cells.Clear 
 
 Application.ScreenUpdating = False 
 
与wsFHA 
对于i = 0到UBound（标题）
 .Cells（2，i + 2）=标题（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））。Horizo​​ntalAlignment = xlCenter 
 .Range（.Cells（1 ，2），.Cells（2，UBound（Headers）+ 2））。Font.Bold = True 
结束
 
 Dim RowCounter As Long：RowCounter = 3 
 Dim SearchTarget As String：SearchTarget =9.1
 Dim SourceCell As Range，FirstAdr As String 
 
如果Workshee ts.Count> 1然后
对于i = 1 To Worksheets.Count  -  1 
带表格（i）
设置SourceCell = .Columns（7）.Find（SearchTarget，LookAt：= xlWhole）
如果不是SourceCell是没有，然后
 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 
设置SourceCell = .Columns（7）.FindNext（SourceCell）
 RowCounter = RowCounter + 1 
循环而不是SourceCell是Noth ing和SourceCell.Address<> FirstAdr 
 End If 
 End With 
 Next i 
 End If 
 Application.ScreenUpdating = True 
 End Sub 
 
公共功能WorksheetExists（ByVal WorksheetName As String）As Boolean 
 On Error Resume Next 
 WorksheetExists =（ThisWorkbook.Sheets（WorksheetName）.Name<>）
 On Error GoTo 0 
结束功能
  

So I have a code I have written the first part of the code is to create a new worksheet with the headings specified. The second part of the code is meant to populate that table with certain information. The problem I am having is getting the correct bits of information to go into the correct columns. I need the code to search for the value 9.1 in column G in all worksheets within a workbook if that value is found I need it to copy this to column b in the new sheet along with the following information :

Engine Effect from Column F Same row must be pasted to Column C in the worksheet entitled FHA Part number is always located in Cell J3 this must be pasted into column D and is always the same Part Name Is Always located in C2 this must be pasted into column E and is always the same FM ID from Column B same row must be pasted to Column F in the worksheet entitled FHA Failure Mode & Cause from Column C Same row must be pasted to column G in FHA FMCN Value From Column N pasted to Column H In FHA

As It stands the code I have is

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

解决方案

You have some mismatches in your code (Example using 'for each wk' then accessing via an index 'i'; where they may not necessarily match)

Try something like this...

I have added in some dynamic flow control which isn't strictly needed but if and when your headers change in the future, it may be easier to have it in this form.

Likewise I have tried to add in some error handling as well

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

这篇关于有搜索功能需要帮助编辑的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！