Duplicate the current column automatically
- Nov. 5, 2016
Example files with this article: | |
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 IfEnd 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 !