Van plaats wisselen

Voorbeeldbestanden bij dit artikel:
  • Van plaats wisselen
  • Snel en efficiënt cellen van plaats verwisselen is niet mogelijk in Excel. Gewoonlijk zal je eerst de cellen kopiëren naar een hulpkolom of hulprij, om dan vervolgens met de muis de cellen één voor één een andere plaats te geven. Onnodig te zeggen dat dit tijdrovend is, snel aanleiding geeft tot fouten, en bovenal… boring is. Stel je maar eens voor dat dit voor duizenden cellen moet gebeuren! Maar het geluk is aan jouw zijde, bovenaan staat code om dit automatisch te doen.

    De code kan getallen of woorden van plaats verwisselen. We onderscheiden 2 gevallen:

    1. celinhouden in een zelf gekozen volgorde verplaatsen
    2. celinhouden in een willekeurige volgorde verplaatsen

    1. celinhouden in een zelf gekozen volgorde verplaatsen

    De code werd geschreven als antwoord op deze vraag. De bedoeling is dat je op voorhand de volgorde kent van de nieuwe cellen en dat je dat ingeeft in de code (je zal zo zien waar dat moet). In de huidige code is dat nu voor 10 cellen gedaan die achterstevoren gezet gaan worden. Pas naar goeddunken aan en breid indien nodig uit. De broncellen zet je allemaal in dezelfde kolom of rij. Er mogen lege cellen in voor komen, die zullen wel mee verplaatst worden.

    Kopieer de code hieronder naar een module in VBA en voer ze uit. Als je wil kan je de code ook achter een knop zetten zodat je enkel nog maar hoeft te klikken.

    Option Base 1
    
    
    Sub VanPlaatsWisselenDETERMINISTISCH()
    ' Wim Gielis ' https://www.wimgielis.com
    ''''' ' Custom module to switch numbers or words in a CHOSEN way ' 24/02/07, revised 30/03/07, 20/05/07 '''''
    Dim rng As Range Dim Cnt As Integer Dim iArr1() As Variant Dim iArr2 As Variant Dim i As Integer Dim sPlaats As String Dim rngPlaats As Range Dim rngOutput As Range Set rng = Application.InputBox("Duid de getallen aan.", "Gegevens", Selection.Address, Type:=8) If WorksheetFunction.Min(rng.Rows.Count, rng.Columns.Count) > 1 Or rng Is Nothing Then MsgBox "Selecteer een goed bereik. O.a. slechts 1 kolom of 1 rij.", vbCritical, "Fout" Exit Sub End If If rng.Columns.Count = 1 Then sPlaats = "rechts van" Set rngPlaats = rng.Cells(1).Offset(, 1) Else sPlaats = "onder" Set rngPlaats = rng.Cells(1).Offset(1) End If Cnt = rng.Count ReDim iArr1(Cnt): ReDim iArr2(Cnt) ''''verander hier de volgorde '(nu is het gewoon achterstevoren, met 10 cellen) iArr1() = Array(10, 9, 8, 7, 6, 5, 4, 3, 2, 1) 'check for same number of elements If Cnt <> UBound(iArr1) Then MsgBox "Het aantal elementen in de volgorde stemt niet overeen met het aantal " & _ "elementen in het bereik." & vbCr & "De macro stopt hier.", vbCritical Exit Sub End If For i = 1 To Cnt iArr2(i) = rng(iArr1(i)) Next Set rngOutput = Application.InputBox("Duid de cel in de LINKERBOVENHOEK aan waar de " _ & "cellen naartoe moeten." & vbCr & vbCr & "Je mag cellen overschrijven." & vbCr _ & vbCr & "(Doe je dit niet goed, dan worden de cellen " & sPlaats & _ " de oorspronkelijke cellen geplaatst.)", "Output", rngPlaats.Address, Type:=8) If rngOutput.Cells.Count > 1 Or rngOutput Is Nothing Then Set rngOutput = rngPlaats If rng.Columns.Count = 1 Then rngOutput.Resize(Cnt) = WorksheetFunction.Transpose(iArr2) Else rngOutput.Resize(, Cnt) = iArr2 End If
    End Sub

    2. celinhouden in een willekeurige volgorde verplaatsen

    Deze vraag was de aanleiding voor het schrijven van de code. Een variant van bovenstaande code is wanneer je de cellen op een willekeurige manier wil verplaatsen, dus op een random manier. Je weet op voorhand niet de volgorde waarin de cellen geplaatst gaan worden. De andere opmerkingen voor de eerste code gelden ook hier.

    Option Explicit
    Option Base 1
    
    
    Sub VanPlaatsWisselenWILLEKEURIG()
    ' Wim Gielis ' https://www.wimgielis.com
    ''''' ' Custom module to switch numbers or words in a RANDOM way
    ' 24/02/07, revised 30/03/07, 20/05/07 '''''
    Dim rng As Range Dim Cnt As Integer Dim iArr1 As Variant Dim iArr2 As Variant Dim temp As Variant Dim i As Integer Dim r As Integer Dim sPlaats As String Dim rngPlaats As Range Dim rngOutput As Range Set rng = Application.InputBox("Duid de getallen aan.", "Gegevens", Selection.Address, Type:=8) If WorksheetFunction.Min(rng.Rows.Count, rng.Columns.Count) > 1 Or rng Is Nothing Then MsgBox "Selecteer een goed bereik. O.a. slechts 1 kolom of 1 rij.", vbCritical, "Fout" Exit Sub End If If rng.Columns.Count = 1 Then sPlaats = "rechts van" Set rngPlaats = rng.Cells(1).Offset(, 1) Else sPlaats = "onder" Set rngPlaats = rng.Cells(1).Offset(1) End If Cnt = rng.Count ReDim iArr1(Cnt): ReDim iArr2(Cnt) For i = 1 To Cnt iArr1(i) = i Next For i = Cnt To 2 Step -1 r = Int(Rnd() * i) + 1 temp = iArr1(r) iArr1(r) = iArr1(i) iArr1(i) = temp Next For i = 1 To Cnt iArr2(i) = rng(iArr1(i)) Next Set rngOutput = Application.InputBox("Duid de cel in de LINKERBOVENHOEK aan waar de cellen naartoe moeten." _ & vbCr & vbCr & "Je mag cellen overschrijven." & vbCr & vbCr & "(Doe je dit niet goed, dan worden de cellen " _ & sPlaats & " de oorspronkelijke cellen geplaatst.)", "Output", rngPlaats.Address, Type:=8) If rngOutput.Cells.Count > 1 Or rngOutput Is Nothing Then Set rngOutput = rngPlaats If rng.Columns.Count = 1 Then rngOutput.Resize(Cnt) = WorksheetFunction.Transpose(iArr2) Else rngOutput.Resize(, Cnt) = iArr2 End If
    End Sub

    De code kan wellicht nuttig zijn bij het opstellen van rekenoefeningen voor zoon- of dochterlief. Of voor het opstellen van een kalender van sportwedstrijden misschien. Te zien aan de 2 topics op het Helpmij forum bewijzen dat er nood is aan zulke code.




    Homepage

    Rubriek onderdelen

    Over Wim

    Wim Gielis is Business Intelligence consultant en Excel expert

    Andere links