wimgielis.com

Automatisch de kolom overnemen als een nieuwe kolom

• 05/11/2016

	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:

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
' https://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 !

• « Vorig Excel artikel
• Volgend Excel artikel »