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

[califrania]

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!

 

[califrania]

I think it involves storing the header names as Arrays

 

[Trebor76]

Hi califrania,

Welcome to MrExcel!!

See how this goes:

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

 

[Trebor76]

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

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

 

[califrania]

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:

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

 

[Trebor76]

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"

 

[califrania]

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

 

[Trebor76]

Oh, OK now I see.

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

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:

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