I couldn't get this to work with the merged cells in Rows 1 and 2 on your Output WB. However, it did once I unmerged the cells. Hope that helps.
Sub rr1050()
Dim x As Range
Dim y As String
Dim i As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 2 To Workbooks("Input WB.xlsx").Sheets("Heading Input").UsedRange.Columns.count
y = Workbooks("Input WB.xlsx").Sheets("Heading Input").Cells(1, i).Value
Workbooks("Input WB.xlsx").Activate
Sheets("Heading Input").Range(Cells(2, i), Cells(Cells(Rows.count, i).End(3).Row, i)).Copy
Workbooks("Output WB.xlsx").Activate
Sheets("Collected Data").Select
Set x = Rows(1).Find(y, LookIn:=xlValues, Lookat:=xlWhole)
If Not x Is Nothing Then
x.Activate
Cells(Rows.count, ActiveCell.Column).End(3)(2).Select
ActiveSheet.Paste
End If
Set x = Nothing
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Bookmarks