VBA Newbie - Copying and pasting from one worksheet to another based on column header

[BG1004]

Hi All,

I know there are hundreds of posts asking the same question but none of them seem to help me with my problem.

I am a VBA newbie and I am trying to transfer data from one worksheet (ws1) to another (ws2)based on column headers. The headers are not in the same order in ws2 and there is already existing data in this worksheet - so any data copied and pasted across, needs to be added to the end of the existing data.

So far, I have the following code:

Sub Planttest1()
'
' Planttest1 Macro
'
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub


Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function


Unfortunately, this code doesn't seem to select all the data I need and it doesn't offest anything (and add it onto the bottom of existing data).

Can anyone help me please?

 

[mumps]

Are you trying to copy the matching columns from ws1 to ws2 based on the headers?

 

[BG1004]

Are you trying to copy the matching columns from ws1 to ws2 based on the headers?

Yes - and make sure they add onto the bottom of the existing data set

 

[mumps]

With Sheet "ws1" being the active sheet, try:

Sub CopyCol()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim Header As Range
    Dim foundHeader As Range
    For Each Header In Sheets("ws1").Range("A1:Z1")
        Set foundHeader = Sheets("Ws2").Range("A1:Z1").Find(Header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            LastRow = Sheets("ws1").Cells(Rows.Count, Header.Column).End(xlUp).Row
            Range(Cells(2, Header.Column), Cells(LastRow, Header.Column)).Copy Sheets("ws2").Cells(Rows.Count, foundHeader.Column).End(xlUp).Offset(1, 0)
        End If
    Next Header
    Application.ScreenUpdating = True
End Sub

 

[BG1004]

Hi mumps, thanks for your help.

It almost works for me.

I should have mentioned that not all of the cells that are being copied have data in them but those blank cells need to remain blank (as the data rows need to remain together when they are transferred). So for example:

Column A: First Name
Column B: Middle Name
Column C: Last Name

If the person doesnt have a middle name, I need the cell in column B to remain blank and the next person's middle name to appear underneath that blank cell. Is that possible?

I hope that makes sense!

Thank you so much for your help - I really appreciate it.

 

[mumps]

I think that it would be much easier to follow if I could see how your data is organized. Perhaps you could upload a copy of your file to a free site such as www.box.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

 

[BG1004]

Thanks for the link. I've uploaded an example of similar data here: https://app.box.com/s/gy382hp0g5n2nnr41y5oqsyh5jhat1y6

Unfortunately, I can't upload the real file as some data is confidential but this file is structure in the same way.

Thanks for your help.

 

[mumps]

Give this a try:

Sub CopyCol()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim bottomA As Long
    bottomA = Sheets("ws2").Range("A" & Rows.Count).End(xlUp).Row
    Dim Header As Range
    Dim foundHeader As Range
    For Each Header In Sheets("ws1").Range("A1:Z1")
        Set foundHeader = Sheets("Ws2").Range("A1:Z1").Find(Header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            LastRow = Sheets("ws1").Cells(Rows.Count, Header.Column).End(xlUp).Row
            Range(Cells(2, Header.Column), Cells(LastRow, Header.Column)).Copy Sheets("ws2").Cells(bottomA + 1, foundHeader.Column)
        End If
    Next Header
    Application.ScreenUpdating = True
End Sub