Excel VBA: Merge worksheets by search/mapping headers? - vba

Question

Looking to up my manual mapping solution of merging worksheets, to a search-map header solution. The basics are this
Dest_Worksheet: This has the only headers that are needed post merge (up to 50 columns)
Source_Worksheet1: This has a list of items with some headers that match Dest_Worksheet (up to 100 columns - different than Source_Worksheet2)
Source_Worksheet2: This has a list of items with some headers that match Dest_Worksheet (up to 100 columns - different than Source_Worksheet1)
Total row count unknown at the time of run. Currently built out a manual mapping (see below).
ASKING: Move beyond manual mapping of each worksheet to a solution which reviews the Dest_Worksheet and references those headers, move through remaining or identified list of Source worksheets and copy all rows with only columns that match Dest_Worksheet.
See sample worksheet for working manual mapping code below
'******Manual Mapping of Source_Data1*******
Sub Source_Data1()
Dim sht As Worksheet
Dim colname As String
Dim Lastrow As Integer, rowcount As Integer
colname = 1
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = "Source_Worksheet1" And sht.Range("A3").Value <> "" Then
Sheets("Source_Worksheet1").Select
Lastrow = Range("A9000").End(xlUp).Row
Sheets("Dest_Worksheet").Select
rowcount = Range("A9000").End(xlUp).Row + 1
sht.Select
Sheets("Dest_Worksheet").Range("A" & rowcount & ":A" & rowcount + Lastrow - 3).Value = sht.Range("A3:A" & Lastrow).Value
Sheets("Dest_Worksheet").Range("B" & rowcount & ":B" & rowcount + Lastrow - 3).Value = sht.Range("B3:B" & Lastrow).Value
Sheets("Dest_Worksheet").Range("C" & rowcount & ":C" & rowcount + Lastrow - 3).Value = sht.Range("C3:C" & Lastrow).Value
Sheets("Dest_Worksheet").Range("D" & rowcount & ":D" & rowcount + Lastrow - 3).Value = sht.Range("D3:D" & Lastrow).Value
End If
Next sht
Worksheets("Dest_Worksheet").Select
End Sub
'******Manual Mapping of Source_Data2*******
Sub Source_Data2()
Dim sht As Worksheet
Dim colname As String
Dim Lastrow As Integer, rowcount As Integer
colname = 1
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = "Source_Worksheet2" And sht.Range("A3").Value <> "" Then
Sheets("Source_Worksheet2").Select
Lastrow = Range("A9000").End(xlUp).Row
Sheets("Dest_Worksheet").Select
rowcount = Range("A9000").End(xlUp).Row + 1
sht.Select
Sheets("Dest_Worksheet").Range("A" & rowcount & ":A" & rowcount + Lastrow - 3).Value = sht.Range("A3:A" & Lastrow).Value
Sheets("Dest_Worksheet").Range("E" & rowcount & ":E" & rowcount + Lastrow - 3).Value = sht.Range("B3:B" & Lastrow).Value
Sheets("Dest_Worksheet").Range("F" & rowcount & ":F" & rowcount + Lastrow - 3).Value = sht.Range("C3:C" & Lastrow).Value
Sheets("Dest_Worksheet").Range("C" & rowcount & ":C" & rowcount + Lastrow - 3).Value = sht.Range("E3:E" & Lastrow).Value
End If
Next sht
Worksheets("Dest_Worksheet").Select
End Sub

Answer 1

After lots of trial and error I got Find() working to return the column letter I'm looking for. Here's the code I ended up using and the associated function call:
Sub LookupText()
Dim DestLetter As String
DestLetter = TextLookup("Search Text")
MsgBox DestLetter
End Sub
'***********
Function TextLookup(TheText As String) As String
Set Cell = Worksheets("Destination_Worksheet").Cells.range("A1:DA1").Find(TheText, , xlValues, xlPart, , , False)
If Not Cell Is Nothing Then
ColLetter = Split(Cell.Address, "$")(1)
TextLookup = ColLetter
End If
End Function