Looping through many search terms and matching to another sheet? - vba

Question

I use a third party to collect data in order to produce a monthly report. In this example, the data dump from the third party is in the sheet called "Data" and the report sheet is called "Month"
Sheets("Data") This is the data dump of unstructured data listed by segment, although the order of the segments do not match my report:
Sheets("Month") This is the structured reporting sheet that lists data by segment appropriate for the report. Copied data from the 'Data' sheet will be pasted into columns O through S
I am looking to write a loop that can search through "Data", find each successive word in column B "Month" and paste the appropriate information from "Data" into "Month".
Right now, I have a long code that works, but it is easily broken if one of the segment names change. This is a small piece that just focuses on Segment 4.
Sub Macro1()
' Macro1 Macro
' For post onto StackOverflow
Dim ws As Worksheet
Dim qb As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Month")
Set qb = ThisWorkbook.Sheets("Data")
'To find Segment 4
With ws
Set aCell = .Columns(2).Find(What:="Segment 4", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.Offset(0, 1).Value = qb.Range("B2")
Else
MsgBox "Segment 4 Not Found"
End If
qb.Range("B2:F2").Copy
aCell.Offset(0, 13).Select
ActiveCell.PasteSpecial
End With
End Sub
Is there a way I can loop through Column B in "Month" and match it to data in Column A in "Data" without having to write a search for each Segment?
Thanks in advance for your input!

Answer 1

How about a For Each loop going through column A of Data:
Sub Macro1()
' Macro1 Macro
' For post onto StackOverflow
Dim ws As Worksheet
Dim qb As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Month")
Set qb = ThisWorkbook.Sheets("Data")
qb.Activate
Dim dataCell As Variant
For Each dataCell In qb.Range(Cells(2, 1), Cells(qb.Cells(qb.Rows.Count, "A").End(xlUp).Row, 1))
With ws
Set aCell = .Columns(2).Find(What:=dataCell.Value, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not aCell Is Nothing Then
Range(aCell.Offset(0, 1), aCell.Offset(0, 5)).Value = Range(dataCell.Offset(0, 1), dataCell.Offset(0, 5)).Value
Else
MsgBox dataCell.Value & " Not Found"
End If
End With
Next dataCell
End Sub