Excel VBA: Merge worksheets by search/mapping headers?

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

Look at using `Find()` to locate specific headers on row1. Also would be a good idea to remove all the `Select/Activate` from your code. https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba — Tim Williams, Nov 13 '17 at 17:24
@TimWilliams - Thanks for the feedback. I'll look into how to incorporate Find() to look for and return the destination column letter so I can use it. One problem at a time, then I'll try and do away with Select/Activate. I'm quite a novice so learning as I go. Feel free to provide some additional tips or samples if you're so inclined! — EricW, Nov 14 '17 at 04:27

score 0 · Accepted Answer · answered Nov 20 '17 at 16:13

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

Excel VBA: Merge worksheets by search/mapping headers?

1 Answers1