Automatisch de bovenliggende rij overnemen
- 04/11/2015
 | Voorbeeldbestanden bij dit artikel: |
Inleiding
Hier zou ik jullie een macro willen tonen die ik zelf op dagdagelijkse basis gebruik. Hiermee kan je de bovenstaande rij in een Excel werkblad overnemen. Dit werkt zowel in een gewoon Excel werkblad, als wanneer de actieve cel zich in een tabel bevat. Dit heeft als voordeel dat je zeer snel een rij kan dupliceren en aanpassen (waar nodig).
Voorbeelden
Hier zijn wat voorbeeldjes:
We klikken op cel C7, bijvoorbeeld, want elke cel in de rij is prima voor deze macro. Vervolgens zal een macro rij 7 overnemen en kopiëren door ze in te voegen als een nieuwe rij onder de huidige rij 7. Beetje moeilijke uitleg misschien maar de schermafdruk maakt veel duidelijk neem ik aan.
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 RijOvernemen()' Wim Gielis ' https://www.wimgielis.com''''' ' Routine om de huidige rij over te nemen als een nieuwe rij eronder ' 04/11/2016 '''''Dim lRow As Long Dim li As ListObject Dim rngStart As Range If TypeName(Selection) = "Range" Then Set rngStart = Selection.Cells(1) lRow = rngStart.Row If lRow < Rows.Count Then Application.ScreenUpdating = False If rngStart.ListObject Is Nothing Then 'non-data table case '==> duplicate the selected row Rows(lRow).Copy Rows(lRow + 1).Insert Shift:=xlDown Rows(lRow + 1).RowHeight = Rows(lRow).RowHeight 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 If li.DataBodyRange Is Nothing Then 'a data table without records '==> insert 2 records li.ListRows.Add AlwaysInsert:=True li.ListRows.Add AlwaysInsert:=True Else 'a data table with at least 1 record '==> duplicate the selected row Application.DisplayAlerts = False 'add a row and copy the contents li.ListRows.Add(lRow - li.DataBodyRange.Row + 2).Range.FillDown Rows(lRow + 1).RowHeight = Rows(lRow).RowHeight rngStart.Offset(1).Select Application.DisplayAlerts = True End If 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
Persoonlijk macrowerkboek
Deze macro gebruik ik zeer vaak, en omwille daarom heb ik er een sneltoetscombinatie voor voorzien (Ctrl + e) en voeg ik de macro toe aan mijn persoonlijk macrowerkboek. Gebruik gerust de macro als je het nuttig vindt.
