Copy data from one sheet to another using headers and placements.

[tonywatsonhelp]

Hi Everyone,
I need a macro, that when run copys data from one sheet to another using header names,

So I have 3 sheets
Raw Data and Clean Data, then Control

In Control,
Column B I want to put the names for my Headers I want copied over, and Column C the destination Headers To Copy to like This

Sheet "Control"

	A	B	C	D
1		Name of Copy Headers	Name of Paste headers
2		Name	Name
3		Sales	Sales Amount
4		Age	D.O.B
5		Amount	Amount
6		etc.
7
8

So what I want the macro to do is take the first Copy Header "Name" and find what column it is in by looking along row 5,
If it not found then in D I want it to say "No Copy Header found" and move on to the next header
If found then copy from row 6 to last row.

then find destination Header name, in sheet " Clean Data row 3"
again if not found, in D I want it to say "No Destination header found" and move on to the next header

So basicly, in this case take the data in Sheet Raw data for each header listed copy and paste it into sheet clean data .

Please help if you can

Thanks
Tony

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your Raw Data and Clean Data sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[tonywatsonhelp]

try this

link to a doc that hopefully shows what i mean

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, fnd1 As Range, fnd2 As Range, rng As Range, srcWS As Worksheet, desWS As Worksheet, crtlWS As Worksheet
    Set srcWS = Sheets("Raw Data")
    Set desWS = Sheets("Clean Data")
    Set crtlWS = Sheets("Control")
    For Each rng In crtlWS.Range("B2", crtlWS.Range("B" & Rows.Count).End(xlUp))
        Set fnd1 = srcWS.Rows(5).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd1 Is Nothing Then
            Set fnd2 = desWS.Rows(3).Find(rng.Offset(, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd2 Is Nothing Then
                With srcWS
                    LastRow = .Cells(.Rows.Count, fnd1.Column).End(xlUp).Row
                    fnd1.Offset(1).Resize(LastRow - 5).Copy fnd2.Offset(1)
                End With
            Else
                MsgBox ("Destination header " & rng.Offset(, 1) & " was not found.")
            End If
        Else
            MsgBox ("Copy header " & rng & " was not found.")
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[tonywatsonhelp]

Brilliant,
Thanks Mumps, exactly what I needed
Thanks
Tony

 

[mumps]

You are very welcome.