wimgielis.com

Van plaats wisselen

• 20/05/2007

	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.

• « Vorig Excel artikel
• Volgend Excel artikel »