Copying Data From One Sheet to Another Based on Column Headers

[scohn80215]

Hi Everyone,

This will be my first post. I've researched this problem for hours and I can't find a solution.

I have two worksheets in the same workbook. Worksheet_A - has 20 columns and Worksheet_B - has about 50 columns. I need a macro, or preferably a index/match formula, to copy the data below each column from Worksheet_B and paste it to Worksheet_A whenever the column headers match.

So for example Worksheet_A looks like

[TABLE="width: 500"]
<tbody>[TR]
[TD]Dogs
[/TD]
[TD]Cats
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

And Worksheet_B looks like
[TABLE="width: 500"]
<tbody>[TR]
[TD]Cats
[/TD]
[TD]Birds
[/TD]
[TD]Dogs
[/TD]
[TD]Reptiles
[/TD]
[TD]Zoo Animals
[/TD]
[/TR]
[TR]
[TD]Siberian
[/TD]
[TD]Love Bird
[/TD]
[TD]Husky
[/TD]
[TD]Snake
[/TD]
[TD]Elephant
[/TD]
[/TR]
[TR]
[TD]Siamese
[/TD]
[TD]Parrot
[/TD]
[TD]Chihuahua
[/TD]
[TD]Frog
[/TD]
[TD]Hippo
[/TD]
[/TR]
</tbody>[/TABLE]

And I need a formula (or macro) that will leave Worksheet_A looking like:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Dogs
[/TD]
[TD]Cats
[/TD]
[/TR]
[TR]
[TD]Husky
[/TD]
[TD]Siberian
[/TD]
[/TR]
[TR]
[TD]Chihuahua
[/TD]
[TD]Siamese
[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet A starts at Row 5 with Column Headers; Worksheet B starts at Row 7 with Column Headers. The number of columns and length of rows in Worksheet_B can change so the formula/macro needs to be dynamic.

Thank so so so much!!

 

[MickG]

Try this for results in "Worksheet_A" starting Row 5 from "Worksheet_B" starting row 7.

[COLOR="Navy"]Sub[/COLOR] MG17Mar17
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] RngAc [COLOR="Navy"]As[/COLOR] Range, r [COLOR="Navy"]As[/COLOR] Range, RngA [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]With[/COLOR] Sheets("Worksheet_B")
    Lst = .Cells("7", Columns.Count).End(xlToLeft).Column
    [COLOR="Navy"]Set[/COLOR] RngAc = .Range("A7", .Cells(7, Columns.Count).End(xlToLeft))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] r [COLOR="Navy"]In[/COLOR] RngAc
      [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Cells(r.Row + 1, r.Column), .Cells(Rows.Count, r.Column).End(xlUp))
        [COLOR="Navy"]If[/COLOR] Not Dic.exists(r.Value) [COLOR="Navy"]Then[/COLOR]
            Dic.Add r.Value, Rng
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] r
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Worksheet_A")
    [COLOR="Navy"]Set[/COLOR] RngA = .Range("A5", .Cells(5, Columns.Count).End(xlToLeft))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] RngA
    [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR] Dn.Offset(1).Resize(Dic(Dn.Value).Count).Value _
    = Application.Transpose(Application.Transpose(Dic(Dn.Value)))
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[scohn80215]

OMG this is incredible! Thank you!

One problem I'm running into. I get a type mismatch (Run-time error '13': Type mismatch) on column G. It copies half the data and then stops. Please help.

Thank you again!

 

[MickG]

Can you send an example of the data it fails on !!
Also specify which line of code does the error occurs.

 

[scohn80215]

Actually, now that I look closer at it, this works perfect. What was happening is there are duplicate column names or mismatches in the column header name.

Truly, I can't tell you how much I appreciate this!!