Macro for copying data from 1 column to another by header name

califrania

New Member
Joined
Jul 28, 2015
Messages
5
Hi, I am new to VBA and am trying to write what is probably a relatively basic macro.

I have one column labeled Data in the first row, with data in the rows following.
I have another column labeled Data2 and I am simply trying to copy the data from the Data column (not including the "Data" header) and paste it below the Data2 header

I need the macro to select the data using the header name rather than column letter so I can add and delete columns -- in other words it should always copy the data under "Data" and always paste under "Data2" regardless of which columns they are in

Any help appreciated, thanks!
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Hi califrania,

Welcome to MrExcel!!

See how this goes:

Code:
Option Explicit
Sub CopyMacro()
    
    Const lngStartRow As Long = 2 'Starting (static) row row for the data. Change to suit, if necessary.

    Dim strColFrom As String
    Dim strColTo As String
    Dim lngMyCol As Long
        
    Application.ScreenUpdating = False
        
    For lngMyCol = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(1, lngMyCol) = "Data" Then
            strColFrom = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        ElseIf Cells(1, lngMyCol) = "Data2" Then
            strColTo = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        End If
    Next lngMyCol
    
    If strColFrom = "" And strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data"" or ""Data2""", vbExclamation
    ElseIf strColFrom = "" Then
        MsgBox "There was no data in row one titled ""Data""", vbExclamation
        Exit Sub
    ElseIf strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data2""", vbExclamation
        Exit Sub
    End If

    Range(strColFrom & lngStartRow, Range(strColFrom & Rows.Count).End(xlUp)).Copy Destination:=Range(strColTo & Rows.Count).End(xlUp).Offset(1, 0)
    
    Application.ScreenUpdating = True
    
    MsgBox "Data has now been copied", vbInformation

End Sub

Regards,

Robert
 
Upvote 0
Here's another more efficient way as it doesn't loop through the column headings:

Code:
Option Explicit
Sub CopyMacro2()

    Const lngStartRow As Long = 2 'Starting (static) row row for the data. Change to suit, if necessary.
    
    Dim rngFoundCell As Range
    Dim varMyHeadings As Variant
    Dim strColFrom As String
    Dim strColTo As String
    
    Application.ScreenUpdating = False
    
    For Each varMyHeadings In Array("Data", "Data2")
        On Error Resume Next
            Set rngFoundCell = Rows(1).Find(What:=varMyHeadings, LookIn:=xlFormulas)
            If rngFoundCell Is Nothing Then
                MsgBox "There is no data in row one titled """ & varMyHeadings & """", vbExclamation
                Exit For
            Else
                If varMyHeadings = "Data" Then
                    strColFrom = Left(Cells(1, rngFoundCell.Column).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, rngFoundCell.Column).Address(True, False)) - 1)
                Else
                    strColTo = Left(Cells(1, rngFoundCell.Column).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, rngFoundCell.Column).Address(True, False)) - 1)
                End If
            End If
        On Error GoTo 0
    Next varMyHeadings
       
    If Not rngFoundCell Is Nothing Then
        Range(strColFrom & lngStartRow, Range(strColFrom & Rows.Count).End(xlUp)).Copy Destination:=Range(strColTo & Rows.Count).End(xlUp).Offset(1, 0)
        MsgBox "Data has now been copied", vbInformation
        Set rngFoundCell = Nothing
    End If
    
    Application.ScreenUpdating = True
    

End Sub

Regards,

Robert
 
Upvote 0
Thanks for the response! This code works the first time I run the macro. However each additional time I run it, the same data posts again underneath itself

Example after 2nd time running macro:
Data1 Data2
1 1
2 2
3 3
1
2
3



Hi califrania,

Welcome to MrExcel!!

See how this goes:

Code:
Option Explicit
Sub CopyMacro()
    
    Const lngStartRow As Long = 2 'Starting (static) row row for the data. Change to suit, if necessary.

    Dim strColFrom As String
    Dim strColTo As String
    Dim lngMyCol As Long
        
    Application.ScreenUpdating = False
        
    For lngMyCol = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(1, lngMyCol) = "Data" Then
            strColFrom = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        ElseIf Cells(1, lngMyCol) = "Data2" Then
            strColTo = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        End If
    Next lngMyCol
    
    If strColFrom = "" And strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data"" or ""Data2""", vbExclamation
    ElseIf strColFrom = "" Then
        MsgBox "There was no data in row one titled ""Data""", vbExclamation
        Exit Sub
    ElseIf strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data2""", vbExclamation
        Exit Sub
    End If

    Range(strColFrom & lngStartRow, Range(strColFrom & Rows.Count).End(xlUp)).Copy Destination:=Range(strColTo & Rows.Count).End(xlUp).Offset(1, 0)
    
    Application.ScreenUpdating = True
    
    MsgBox "Data has now been copied", vbInformation

End Sub

Regards,

Robert
 
Upvote 0
the same data posts again underneath itself

Correct - isn't that what you meant by " in other words it should always copy the data under "Data" and always paste under "Data2" regardless of which columns they are in" :confused:
 
Upvote 0
Sorry if that was unclear - I always want the 2 columns to have the same data. So if I delete or add data under Data1, I want those same changes shown under Data2, rather than adding on to the current data under Data2
 
Upvote 0
Oh, OK now I see.

Here's the first macro tweaked for that need...

Code:
Option Explicit
Sub CopyMacro()
    
    Const lngStartRow As Long = 2 'Starting (static) row row for the data. Change to suit, if necessary.

    Dim strColFrom As String
    Dim strColTo As String
    Dim lngMyCol As Long
    Dim lngLastRow As Long
        
    Application.ScreenUpdating = False
        
    For lngMyCol = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Cells(1, lngMyCol) = "Data" Then
            strColFrom = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        ElseIf Cells(1, lngMyCol) = "Data2" Then
            strColTo = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        End If
    Next lngMyCol
    
    If strColFrom = "" And strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data"" or ""Data2""", vbExclamation
    ElseIf strColFrom = "" Then
        MsgBox "There was no data in row one titled ""Data""", vbExclamation
        Exit Sub
    ElseIf strColTo = "" Then
        MsgBox "There was no data in row one titled ""Data2""", vbExclamation
        Exit Sub
    End If

    'Need to clear the existing data in case there were more records previously then now
    lngLastRow = Cells(Rows.Count, strColTo).End(xlUp).Row
    If lngLastRow >= lngStartRow Then
        Range(strColTo & lngStartRow & ":" & strColTo & lngLastRow).ClearContents
    End If
    'Now copy the data across
    lngLastRow = Cells(Rows.Count, strColFrom).End(xlUp).Row
    Range(strColFrom & lngStartRow & ":" & strColFrom & lngLastRow).Copy Destination:=Range(strColTo & lngStartRow)
        
    Application.ScreenUpdating = True
    
    MsgBox "Data has now been copied", vbInformation

End Sub

...and here's the second:

Code:
Option Explicit
Sub CopyMacro2()

    Const lngStartRow As Long = 2 'Starting (static) row row for the data. Change to suit, if necessary.
    
    Dim rngFoundCell As Range
    Dim varMyHeadings As Variant
    Dim strColFrom As String
    Dim strColTo As String
    Dim lngLastRow As Long
    
    Application.ScreenUpdating = False
    
    For Each varMyHeadings In Array("Data", "Data2")
        On Error Resume Next
            Set rngFoundCell = Rows(1).Find(What:=varMyHeadings, LookIn:=xlFormulas)
            If rngFoundCell Is Nothing Then
                MsgBox "There is no data in row one titled """ & varMyHeadings & """", vbExclamation
                Exit For
            Else
                If varMyHeadings = "Data" Then
                    strColFrom = Left(Cells(1, rngFoundCell.Column).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, rngFoundCell.Column).Address(True, False)) - 1)
                Else
                    strColTo = Left(Cells(1, rngFoundCell.Column).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, rngFoundCell.Column).Address(True, False)) - 1)
                End If
            End If
        On Error GoTo 0
    Next varMyHeadings
        
    'Need to clear the existing data in case there were more records previously then now
    lngLastRow = Cells(Rows.Count, strColTo).End(xlUp).Row
    If lngLastRow >= lngStartRow Then
        Range(strColTo & lngStartRow & ":" & strColTo & lngLastRow).ClearContents
    End If
    'Now copy the data across
    lngLastRow = Cells(Rows.Count, strColFrom).End(xlUp).Row
    Range(strColFrom & lngStartRow & ":" & strColFrom & lngLastRow).Copy Destination:=Range(strColTo & lngStartRow)
        
    Application.ScreenUpdating = True
    
    MsgBox "Data has now been copied", vbInformation
    
End Sub

I'll leave it up to you which one you use (I'd use the second FWIW).

Regards,

Robert
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,558
Latest member
aivin

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
Back
Top