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

``此時，我們從工作簿（srcWBook）行開始，為您創建工作表並將其命名的代碼''。

''然后將活動單元格設置到您要開始放置數據的任何位置，並進行如下操作

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