Automatisch de kolom overnemen als een nieuwe kolom

Voorbeeldbestanden bij dit artikel:
  • Kolom overnemen
  • Inleiding

    Een jaartje geleden blogde ik over een tijdsbesparende macro om de geselecteerde rij te dupliceren als een nieuwe rij. Hier vind je het artikel. Zo blij dat ik met mijn macro ben, heb ik ook een macro geschreven voor het dupliceren van een kolom. Opnieuw mocht ik ervaren dat dit voor gewone kolommen niet zo lastig is, maar wanneer de selectie zich bevindt in een tabel (ListObject) dan wordt het een ander verhaal.

    Voorbeelden

    Hier zijn wat voorbeeldjes:




    wordt:

    We klikken op een cel in de gewenste kolom en drukken Ctrl + Shift + e. Het resultaat is de kolom Datum2. De naam van de kolom zal je gevraagd worden en kan je gewoon intypen.

    VBA-code

    Hieronder druk ik de code af, al zit de code ook in het voorbeeldbestand bij dit artikel. Je gaat in de code merken dat ik test of de selectie (actieve cel) zich in een datatabel bevindt of niet. Indien wel, dan is de code wat lastiger.

    Sub KolomOvernemen()
    ' Wim Gielis ' http://www.wimgielis.com
    ''''' ' Routine om de huidige kolom over te nemen als een nieuwe kolom rechts ' 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

    Opnieuw maak ik het onderscheid tussen 2 situaties: de geselecteerde cel maakt deel uit van een tabel, of niet. Daarnaast kan je zien in de code dat ik de kolombreedtes respecteer. Dit is niet voordehandliggend, zoals jullie wel weten bij ListObjects. Leuk in de code van de tabellen is ook dat de formule voor het totaal (als die er is), mee overgenomen wordt. Zelfs als het een custom berekening is. Mochten er een filter actief staan op het moment dat je kolom wil dupliceren, dan zal eerst de filter uitgeschakeld worden.

    Have fun !




    Over Wim

    Wim Gielis is Business Intelligence consultant en Excel expert

    Andere links