Excel Search VBA macro - vba

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

Answer 1

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