wimgielis.com

Duplicate the current column automatically

• Nov. 5, 2016

	Example files with this article:
	Duplicate column

Introduction

1 year ago I blogged about a timesaving macro to duplicate the selected row as a new row underneath. Here you will find the article. I am so happy with my macro that I wrote a variant to duplicate a column. Again I could experience that for normal columns this is not very hard, but whenever the selection is part of a table (ListObject) things are more complicated.

Examples

Here is an example:

becomes:

We click on a cell in the desired column and press Ctrl + Shift + e. The result is the column Date2. You will be asked to enter the name of the column.

VBA code

Below I present the code, but needless to say the code is also part of the example file that accompanies this article. You will see in the code that I test whether the active cell is part of a table or not. If yes, the code will be less easy, even difficult.

Sub DuplicateColumn()
' Wim Gielis
' https://www.wimgielis.com
'''''
' Procedure to duplicate the currently selected column as a new column to the right
' 05/11/2016
'''''
    Dim lColumn               As Long
    Dim li                    As ListObject
    Dim rngStart              As Range
    Dim lColumnPosition_Old   As Long
    Dim lColumnPosition_New   As Long
    Dim blnShow               As Boolean
    Dim blnHideAgain          As Boolean

    Dim rng                   As Range
    Dim i                     As Integer
    Dim sglColumWidths(1)     As Single

    If TypeName(Selection) = "Range" Then

        Set rngStart = Selection.Cells(1)

        lColumn = rngStart.Column

        If lColumn < Columns.Count Then

            Application.ScreenUpdating = False

            If rngStart.ListObject Is Nothing Then

                'non-data table case

                '==> duplicate the selected row
                Columns(lColumn).Copy
                Columns(lColumn + 1).Insert Shift:=xlRight
                Columns(lColumn + 1).ColumnWidth = Columns(lColumn).ColumnWidth
                rngStart.Offset(, 1).Select

            Else

                'data table case

                Set li = rngStart.ListObject

                If li.SourceType = xlSrcRange Then

                    'turn off filters if applicable
                    If li.AutoFilter.FilterMode Then
                        li.AutoFilter.ShowAllData
                    End If

                    Application.DisplayAlerts = False

                    lColumnPosition_Old = lColumn - li.Range.Column + 1
                    lColumnPosition_New = lColumnPosition_Old + 1

                    'trace column widths
                    Set rng = li.Range.Rows(1)
                    ReDim sglColumnWidths(1 To rng.Columns.Count)
                    For i = 1 To rng.Columns.Count
                        sglColumnWidths(i) = rng.Columns(i).ColumnWidth
                    Next

                    'add a column and copy the contents
                    li.ListColumns.Add(Position:=lColumnPosition_New).Range.FillRight

                    'apply column widths again
                    Set rng = li.Range.Rows(1)
                    For i = 1 To rng.Columns.Count
                        If i <= lColumnPosition_Old Then
                            rng.Columns(i).ColumnWidth = sglColumnWidths(i)
                        Else
                            rng.Columns(i).ColumnWidth = sglColumnWidths(i - 1)
                        End If
                    Next

                    'table header
                    blnShow = li.ShowHeaders
                    blnHideAgain = False
                    If Not blnShow Then
                        li.ShowHeaders = True
                        blnHideAgain = True
                    End If
                    li.ListColumns(lColumnPosition_New).Name = InputBox("Name of the new column?", "New column name", li.ListColumns(lColumnPosition_New).Name)
                    If blnHideAgain Then
                        li.ShowHeaders = False
                    End If

                    'table totals
                    Select Case li.ListColumns(lColumnPosition_Old).TotalsCalculation
                    Case 0:                      'no totals
                    Case 1 To 8:                 'carry over total formula
                        li.ListColumns(lColumnPosition_New).TotalsCalculation = li.ListColumns(lColumnPosition_Old).TotalsCalculation
                    Case 9:                      'custom formula
                        blnShow = li.ShowTotals
                        blnHideAgain = False
                        If Not blnShow Then
                            li.ShowTotals = True
                            blnHideAgain = True
                        End If

                        With li.TotalsRowRange.Cells(1, lColumnPosition_New)
                            .Formula = Replace(.Offset(, -1).Formula, "[" & li.ListColumns(lColumnPosition_Old).Name & "]", _
                                "[" & li.ListColumns(lColumnPosition_New).Name & "]")
                        End With

                        If blnHideAgain Then
                            li.ShowTotals = False
                        End If

                    End Select

                    rngStart.Offset(, 1).Select

                    Application.DisplayAlerts = True

                Else

                    MsgBox "This Table has a SourceType = " & li.SourceType & ", which is not supported in this macro." & vbNewLine & vbNewLine & _
                           Replace(Replace("0_NO SUPPORT_External data source (Microsoft SharePoint Foundation site)_(xlSrcExternal)|" & _
                                           "1_SUPPORT__Range_(xlSrcRange)|2_NO SUPPORT_XML_(xlSrcXml)|3_NO SUPPORT_Query_(xlSrcQuery)|4_NO SUPPORT_PowerPivot Model_(xlSrcModel)", _
                                           "|", vbNewLine), "_", vbTab), vbInformation

                End If

            End If

            Application.ScreenUpdating = True

        End If

    End If

End Sub

Again, I distinguish 2 situations: the selected cell is part of a table, or not. Next to that you can see that I respect the column widths. The latter is not straightforward, as you will probably know, with ListObjects. Another nice feature in the code for tables, is that I set the same totals formula for the new column, as we had for the original column (if any). Even in the case of a custom calculation. In case a filter is active at the time of duplicating the column, the filter will be deactivated.

Have fun !

• « Previous Excel article
• Next Excel article »