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

BG1004

New Member
Joined
Sep 1, 2014
Messages
6
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?
 

Some videos you may like

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,160
Are you trying to copy the matching columns from ws1 to ws2 based on the headers?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,160
With Sheet "ws1" being the active sheet, try:
Code:
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

New Member
Joined
Sep 1, 2014
Messages
6

ADVERTISEMENT

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

Well-known Member
Joined
Apr 11, 2012
Messages
10,160
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.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,160
Give this a try:
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,223
Messages
5,600,399
Members
414,383
Latest member
kevinlarey

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top