Excel 搜索 VBA 宏

Question

我的任务是搜索大量 数据。数据在大约 50 个工作表中以相同的方式呈现。我 需要一个宏来搜索所有这些工作表以查找特定的 然后值将某些单元格复制到在新工作簿中创建的表中。 宏在运行时还需要创建表格标题。

一定是Search column G For the Value 9.1 然后是某些信息 必须复制到表中对应的列

• FHA Ref = G 列中的相同行值
• 引擎效果 = F 列中的相同行值
• 部件号 = 始终单元格 J3
• 部件名称 = 始终单元格 C2
• FM ID = B 列中的相同行值
• 失败模式和原因 = C 列中的相同行值
• FMCN = C 列中的相同行值"`

如果使用这些列创建新工作簿很麻烦 标题然后我会很乐意自己创建标题 工作表，只需宏搜索并将数据复制到 与标题对应的行。

如果需要任何帮助或备份文件，我将非常乐意 提供这些。

我现在的代码是基于用户表单的

    Public Sub createWSheet(module, srcWBook)
        Dim i

        i = 0
        srcWB = srcWBook
      For Each ws In Workbooks(srcWBook).Worksheets
            i = i + 1
            If ws.Name = module Then
                MsgBox ("A worksheet with for this module already exists")
                Exit Sub
            End If
        Next ws

        Workbooks(srcWBook).Activate
        Worksheets.Add after:=Worksheets(i)
        ActiveSheet.Name = module
        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) = "FMCN"
        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)) = "Interface"
        Range(Cells(1, 2), Cells(1, 10)).MergeCells = True
        Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True
        Workbooks(srcWBook).Activate
    End Sub
Dim mainWB, srcWBook
Dim headerLeft, headerTop, headerBottom, headerRight
Dim nTargetFMECA, nPartID, nLineID, nPartNo, nPartName, nQTY, nFailureMode, nAssumedSystemEffect, nAssumedEngineEffect
Dim item As String
Dim mDest
Dim selections(100)


Public Sub controlCopyFMs(mWB, sWB, module)
    Dim i

    mainWB = mWB
    srcWBook = sWB
    mDest = 2

    nTargetFMECA = 0
    nPartID = 0
    nLineID = 0
    nPartNo = 0
    nPartName = 0
    nQTY = 0
    nFailureMode = 0
    nAssumedSystemEffect = 0
    nAssumedEngineEffect = 0

    For i = 0 To TestForm.LBSelected.ListCount - 1
        Call copyFMs(module, selections(i))
    Next i
End Sub




    Public Sub copyFMs(module, comp)
        Dim mSrc

        Workbooks(srcWBook).Sheets(comp).Select
        If exploreHeader(comp) = 0 Then
            Exit Sub
        End If

        mSrc = headerBottom + 3

        While Cells(mSrc, nSrc).Text <> ""
            If Cells(mSrc, nIndication).Text <> "-" Then
                If Cells(mSrc, nIndication).Text <> "" Then
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 2) = Cells(mSrc, nTargetFMECA).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 3) = Cells(mSrc, nPartID).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 4) = Cells(mSrc, nLineID).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 5) = Cells(mSrc, nPartNo).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 6) = Cells(mSrc, nPartName).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 7) = Cells(mSrc, nQTY).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 8) = Cells(mSrc, nFailureMode).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 9) = Cells(mSrc, nAssumedEngineEffect).Value
                    Workbooks(mainWB).Worksheets(module).Cells(mDest, 10) = Cells(mSrc, nAssumedSystemEffect).Value
                    mDest = mDest + 1
                End If
            End If
            mSrc = mSrc + 2
        Wend
    End Sub



    Public Function exploreHeader(comp)
        Dim m, n

        m = 1
        n = 1

        While ((InStr(1, Cells(m, n).Text, "Engine Programme:", vbTextCompare) <= 0) Or (InStr(1, Cells(m, n).Text, "BR700-725", vbTextCompare) <= 0)) And n < 10
            If m < 10 Then
                m = m + 1
            Else
                n = n + 1
                m = 1
            End If
        Wend

        headerTop = m
        headerLeft = n

        While StrComp(Cells(m, n).Text, "ID", vbTextCompare) <> 0 And StrComp(Cells(m, n).Text, "Case No.", vbTextCompare) <> 0
            m = m + 1
        Wend
        headerBottom = m - 1

        While Cells(m, n).Borders(xlEdgeBottom).LineStyle = xlContinuous
            n = n + 1
        Wend
        headerRight = n - 1

        m = headerTop
        n = headerLeft
        Do
            If n > headerRight Then
                n = headerLeft
                m = m + 1
            End If

            If InStr(1, Cells(m, n).Value, "Item No.:", vbTextCompare) > 0 Then
                item = Right(Cells(m, n).Value, Len(Cells(m, n).Value) - InStr(1, Cells(m, n).Value, ":", vbTextCompare))
                Cells(m, n).Select
                Exit Do
            End If

            n = n + 1
        Loop While m <= headerBottom

        m = headerBottom + 1
        n = headerLeft
        While n <= headerRight
            If StrComp(Cells(m, n).Value, "ID", vbTextCompare) = 0 Then
                nID = n
            End If

            If StrComp(Cells(m, n).Value, "Mitigation", vbTextCompare) = 0 Then
                nMitigation = n
            End If

            If StrComp(Cells(m, n).Value, "Remarks", vbTextCompare) = 0 Then
                nRemarks = n
            End If

            If StrComp(Cells(m, n).Value, "FMCN", vbTextCompare) = 0 Then
                nFMCN = n
            End If

            If StrComp(Cells(m, n).Value, "Indication", vbTextCompare) = 0 Then
                nIndication = n
            End If

            If StrComp(Cells(m, n).Value, "Crit", vbTextCompare) = 0 Then
                nFMCN = n
            End If

            If StrComp(Cells(m, n).Value, "Detect", vbTextCompare) = 0 Then
                nIndication = n
            End If

            If StrComp(Cells(m, n).Value, "Functional Description", vbTextCompare) = 0 Then
                nMitigation = n
            End If

            n = n + 1
        Wend
        exploreHeader = 1
    End Function


    Public Sub initSelections()
        For i = 0 To 99
            selections(i) = ""
        Next i
    End Sub


    Public Sub loadSelection(comp, i)
        selections(i) = comp
    End Sub



    Public Sub deleteSelection(i)
        While selections(i) <> ""
            selections(i) = selections(i + 1)
            i = i + 1
        Wend
    End Sub

Answer 1

我希望这可以帮助更多。此代码可能无法 100% 工作，但它应该足以指导您。如果您有任何问题，请告诉我。

Dim WS As Worksheet
Dim Results(7, 1000000) As String ''Didn't know what is a good data type or how many possible results
Dim ColValue() As Variant
Dim I, II, ResultCt As Long


ResultCt = 0

For Each WS In ActiveWorkbook.Worksheets ''This should get all your result and information into the Results Array

    ColValue = ActiveSheet.Range(Cells(2, 7), Cells(WS.UsedRange.Rows.Count, 7)).Value ''This put all of column G into an array

    For I = 0 To UBound(ColValue)
        If ColValue(I, 1) = "9.1" Then
            Results(0, ResultCt) = Cells(I + 1, 7).Value ''I think it is off by 1, but if not remove the +1
            Results(1, ResultCt) = Cells(I + 1, 6).Value
            Results(2, ResultCt) = Cells(3, 10).Value
            Results(3, ResultCt) = Cells(2, 3).Value
            Results(4, ResultCt) = Cells(I + 1, 2).Value
            Results(5, ResultCt) = Cells(I + 1, 3).Value
            Results(6, ResultCt) = Cells(I + 1, 3).Value
            ResultCt = ResultCt + 1
        End If
    Next

Next WS

''此时我们使用您的代码来创建工作表并为其命名 ''从 Workbooks(srcWBook).Activate 行开始

''然后将活动单元格设置为您想要开始放置数据的位置并具有类似的内容

For I = 0 To UBound(Results, 2)
    For II = 0 To UBound(Results)
        ActiveCell.Offset(I, II).Value = Results(I, II) ''This assumes you put the information into Result in the order you want it printed out
    Next
Next