Excel VBA to Copy Every Column in a Sheet to the Next Column to the Right

Question

I need to accomplish something very simple: copy a complete column to the next column to the right in the same worksheet (I have around 300 of those columns in one sheet of a workbook) meaning that the macros has to copy every odd column in range to next even column so that I end up having a range full of duplicate columns. I understand that I need to use the following formula in part or in full:

cells(selection.row, columns.Count).end(xltoleft).offset(,1).select

What would be the complete macros though? Searched every available board and found only solutions with custom conditions. Mine should be really simple. Thank you for your input.

Answer 1

If you're hoping to essentially duplicate every column by inserting a copy of each column to the right I think you need the below code.

i.e. this copies columns:

A | B | C 
---------
A | B | C 
1 | 2 | 3 

to

A | B | C | D | E | F
---------------------
A | A | B | B | C | C
1 | 1 | 2 | 2 | 3 | 3

VBA

Option Explicit

Sub CopyAllColsOneToRight()

    Dim ws As Worksheet
    Dim lastCol As Long
    Dim lastRow As Long
    Dim currentCopyCol As Long

    Application.ScreenUpdating = False 'optimise performance by not updating the screen as we move stuff
    Set ws = ActiveSheet
    lastCol = GetLastUsedColumn(ws).Column
    lastRow = GetLastUsedRow(ws).Row

    For currentCopyCol = lastCol To 1 Step -1
        CopyColumnInsertRight ws, lastRow, currentCopyCol
        'CopyColumn ws, lastRow, currentCopyCol, lastRow, currentCopyCol * 2
        'CopyColumn ws, lastRow, currentCopyCol, lastRow, currentCopyCol * 2 - 1
    Next

End Sub

Sub CopyColumnInsertRight(ByRef ws As Worksheet, fromLastRow, fromCol)
    Dim fromRange As Range
    Set fromRange = ws.Range(ws.Cells(1, fromCol), ws.Cells(fromLastRow, fromCol))
    fromRange.Copy
    fromRange.Insert Shift:=XlDirection.xlToRight
End Sub

'Sub CopyColumn(ByRef ws As Worksheet, fromLastRow, fromCol, toLastRow, toCol)
'   Dim fromRange As Range
'   Dim toRange As Range
'   Set fromRange = ws.Range(ws.Cells(1, fromCol), ws.Cells(fromLastRow, fromCol))
'   Set toRange = ws.Range(ws.Cells(1, toCol), ws.Cells(toLastRow, toCol))
'   toRange.Value2 = fromRange.Value2
'End Sub

Function GetLastUsedColumn(ByRef ws As Worksheet) As Range
    Set GetLastUsedColumn = ws.Cells.Find( _
        What:="*" _
        , After:=ws.Cells(1, 1) _
        , LookIn:=XlFindLookIn.xlFormulas _
        , LookAt:=XlLookAt.xlPart _
        , SearchOrder:=XlSearchOrder.xlByColumns _
        , SearchDirection:=XlSearchDirection.xlPrevious _
        , MatchCase:=False _
    )
End Function

Function GetLastUsedRow(ByRef ws As Worksheet) As Range
    Set GetLastUsedRow = ws.Cells.Find( _
        What:="*" _
        , After:=ws.Cells(1, 1) _
        , LookIn:=XlFindLookIn.xlFormulas _
        , LookAt:=XlLookAt.xlPart _
        , SearchOrder:=XlSearchOrder.xlByRows _
        , SearchDirection:=XlSearchDirection.xlPrevious _
        , MatchCase:=False _
    )
End Function

Notes on the code:

• We disable screen updating; this avoids refreshing the UI whilst the macro runs, making the process more efficient.
• We get the last populated column so that instead of copying every column on the worksheet we can limit those copied to the ones which make a difference (i.e. much faster for spreadsheets using less that the full number of columns; which will be true of most)
• We get the last populated row so that instead of copying entire columns we only copy populated rows. We could check for the last used cell per row, but that's likely less efficient since typically the last row will be the same for most columns in range. Also, when using the insert method this is required to ensure that xlToRight doesn't cause cells to be shifted into the wrong columns.
• Our for loop has Step -1 since if we went from left to right we'd overwrite columns to the right as we copied others (e.g. copying A to B overwrites what's in B, then when we copy B to C we're actually copying the copy). Instead we work backwards so that we're always copying to blank columns or to columns we've previously copied.
• I've provided a commented out version which only copies values (faster than copying formats), and another version which uses Insert to create the new columns. One may perform better than the other, but I've not tested so far (NB: The copy has to copy twice as many cells as it doesn't keep the originals but creates 2 copies, whilst the insert method keeps the originals and inserts a copy to the right, but has the additional overhead of copying formatting data).

Answer 2

Try (might need some error handling). Rather than copying entire columns I am using column A to determine the last row of data in the sheet (you can change this) then I am looping the even columns setting them equal to the prior odd columns.

Option Explicit

Sub test()

    Dim loopRange As Range

    Set loopRange = ThisWorkbook.ActiveSheet.Columns("A:AE")

    Dim lastRow As Long

    With ThisWorkbook.ActiveSheet

        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    End With

    Dim currentColumn As Long

    With loopRange

        For currentColumn = 2 To .Columns.Count Step 2

            .Range(.Cells(1, currentColumn), .Cells(lastRow, currentColumn)) = .Range(.Cells(1, currentColumn - 1), .Cells(lastRow, currentColumn - 1)).Value

        Next currentColumn

    End With

End Sub

If you know the last row:

 Option Explicit

    Sub test()

        Dim loopRange As Range

        Set loopRange = ThisWorkbook.ActiveSheet.Columns("A:AE")

        Const lastRow As Long = 108

        Dim currentColumn As Long

        With loopRange

            For currentColumn = 2 To .Columns.Count Step 2

                .Range(.Cells(1, currentColumn), .Cells(lastRow, currentColumn)) = .Range(.Cells(1, currentColumn - 1), .Cells(lastRow, currentColumn - 1)).Value

            Next currentColumn

        End With

    End Sub

Answer 3

I'm not entirely sure I understood the issue, but please find below a suggestion. The code may be a bit messy since I used a recorded macro:

Sub CopyRows()

Range("A1").Activate

While Not IsEmpty(ActiveCell)
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Copy
    ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.Offset(0, 1).Range("A1").Select
Wend

End Sub