Excel Search VBA macro

Question

I have been given the task of searching through a large volume of data. The data is presented identically across around 50 worksheets. I need a macro which searches through all these sheets for specific values then copies certain cells to a table created in a new workbook. The macro also needs to create the table headings when it is run.

It must Search column G For the Value 9.1 Then certain information must be copied to corresponding columns in the table

FHA Ref = Same row value from column G
Engine Effect = Same row value from column F
Part Number = Always cell J3
Part Name = Always cell C2
FM ID = Same Row value from Column B
Failure Mode & Cause = Same Row Value from Column C
FMCN = Same Row Value From Column C"`

If it is a hassle to create the new workbook with these column headings then I would be quite happy to create the headings myself in the worksheet and just have the macro search for and copy the data to the rows corresponding to the headings.

If any help or backup files are needed I would be more than happy to provide these.

the code I have at the moment is based on a userform also ideally I would do away with this and just search all sheets

    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

@eirikdaude at the moment all I have is code to create the workbook, I have never created a function like this so I don't even know where to start. — SeanBaird
As a start, the function you'll probably use to find something within column G, is probably Worksheets("Sheet1").Range("G:G").Find(What:=9.1, .... This returns a range-value if it finds something, and nothing if not. If it returns a range object, you can use Offset to refer to cells relative to it. Looking up those two functions, and attempting to write some code for what you want to do makes it much more likely that you'll get some help figuring out your problems. — eirikdaude
I have amended my question to include the code I have at the moment, im fairly new to VBA. but ill give what you've suggested a shot. — SeanBaird
Whats the difference between Failure Mode & Cause and FMCN? it looks like they come from the same spot. — Holmes IV

Holmes IV Holmes IV · Accepted Answer · 2015-06-16T00:25:07

I hope this can help more. This code may not work 100% but it should be good enough to guide you. Let me know if you have questions.

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

''At this point us your code to create the worksheet and name it ''starting from the line Workbooks(srcWBook).Activate

''Then Set the Active cell to where ever you want to start putting the data and have something like

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

Excel Search VBA macro

1 Answers