Verschuiving groep cellen per kolom

Status
Niet open voor verdere reacties.
B

bomseler

Gebruiker
Lid geworden
31 aug 2016
Berichten
53
Beste forumgebruikers,

Ik wil een macro maken waarmee ik cellen in een range naar links of naar rechts kan verschuiven.

Dus ik selecteer een bepaalde range, deze moet compleet opgeschoven naar (bv) rechts. Omdat ik de kolom waar 'WAAR' boven staat leeg wil laten heb ik een variabele ingebouwd die checkt of het geselecteerde deel van de kolom 1/2 kolommen naar rechts geschoven moet worden.

Nu lukt het niet om de geselecteerde rijen uit te lezen en te gebruiken voor elke cl waarde in de geselecteerde range.
Daarnaast moet ik er ook rekening mee houden dat het verschuiven naar rechts in de meest rechtse geselecteerde kolom begint (ivm het overschrijven van de gegevens).

Ik heb al het e.e.a. geprobeerd maar het lukte steeds niet. Een klein stukje van de code staat nog in het vb bestand zodat het iets duidelijker is wat ik bedoel.
Dit voorbeeld gaat ervan uit dat range B6:F8 geselecteerd en 1 plek naar rechts verschoven moet worden.

Kan iemand me hier een klein beetje mee op weg helpen?

Alvast bedankt!
 

Bijlagen

  • Voorbeeld_verschuiving.xlsm
    13,2 KB · Weergaven: 30
Dit?
Code: 
Sub hsv()
Dim arr
 arr = Selection
 Selection.ClearContents
 Selection.Offset(, 1) = arr
End Sub
 
Beste Harry,

Dit werkt inderdaad wel maar het is niet helemaal wat ik bedoel.

Binnen de selection die ik maak moeten de kolommen om de beurt opgeschoven worden. Zo kan ik een variabele inbouwen die bepaalde kolommen over slaat.

vb. uitgelegd aan de hand van mijn voorbeeldbestand:

ik selecteer B6:F8, maar kolom E(rij 3) = WAAR, deze wil ik overslaan. De macro moet dan de geselecteerde rijen per kolom verplaatsen. (van rechts naar links gezien omdat ik anders de waarde in de volgende kolom overschrijf).

F6 : F8 > G6 : G8
D6 : D8 > F6 : F8 (omdat kolom E overgeslagen moet worden)
C6 : C8 > D6 : D8
etc.


Is dit duidelijker? Alvast bedankt!

mvg,
Jeroen
 
Ik heb nu het volgende, dit werkt echter nog niet...

ik moet srow1 en srow2 nog definiëren, of is er ook een andere manier om deze in te vullen?


Code: 
Sub Test1()

Dim cl As Range
Dim srow1 As Long
Dim srow2 As Long
Dim var As Integer
Dim arr

arr = Selection
'srow1 = bovenste rij van selectie
'srow2 = onderste rij van selectie

For Each cl In arr.EntireColumn
    
    Set var = 1
    
        If Cells(3, cl) = True Then Resume Next
        End If
        
    Range(Cells(srow1, cl), Cells(srow2, cl)).Cut
    Selection.Offset(, 1).Select
    
        Do Until Cells(3, cl) = True
        var = var + 1
        Selection.Offset(, var).Select
        Loop
    
    Range(Cells(srow1, cl + var), Cells(srow2, cl + var)).Paste
Next

End Sub
 
Waar is dit allemaal goed voor.
Is de selectie altijd hetzelfde?
Niet dat ik het helemaal niet begrijp, maar ik vind het van die rare dingen.

Plaats een bestand met hoe het is en daaronder hoe het moet worden, indien de selectie niet altijd hetzelfde is plaats daar nog zo'n rijtje onder met hoe het moet worden.
Geef daarbij aan waarom en hoe of wat.
 
Hierbij het bestand met 'voor' en 'na'.

De macro moet op elke willekeurige selectie in het blad uitgevoerd kunnen worden.

Het is voor een planning. De grijze kolom geeft dan een vrije dag aan en hier mag dus niks in gepland worden als de planning opgeschoven wordt. Het kan zijn dat er meerdere vrije dagen na elkaar komen, in dat geval zal er dus verder geschoven moeten worden.

Dus als de cel in rij 3 'WAAR' is moet de variabele +1 krijgen en weer opnieuw checken of de cel in rij 3 van de volgende kolom 'WAAR' is.

Uiteindelijk wil ik hier nog een inputbox aan koppelen zodat ik zelf kan bepalen hoeveel kolommen deze opschuift. (eventueel naar rechts en links, hoeft nooit naar onder/boven)
 

Bijlagen

  • Voorbeeld_verschuiving.xlsm
    17,1 KB · Weergaven: 36
Zoiets dus.
Code: 
Sub hsv()
Dim rc, c As Range, i As Long, j As Long
Set c = Selection
For i = 1 To c.Rows.Count
  For j = c.Columns.Count To 1 Step -1
   With Cells(c.Rows(i).Row, c.Cells(j).Column)
    If .Value <> "" Then
     rc = Application.Match(False, Range(Cells(2, c.Columns(j).Column + 1), "g2"), 0)
      If Not IsError(rc) Then
        .Offset(, rc) = Cells(c.Rows(i).Row, c.Cells(j).Column).Value
        .ClearContents
      End If
    End If
   End With
  Next j
Next i
End Sub
 
Werkt perfect! super bedankt.

Ik heb de code nog wat aangepast met een inputbox.

Code: 
Sub Test1()

Dim rc, c As Range, i As Long, j As Long
Dim x As Long

x = InputBox("Voer in:")
Set c = Selection

For i = 1 To c.Rows.Count
  For j = c.Columns.Count To 1 Step -1
   With Cells(c.Rows(i).Row, c.Cells(j).Column)
    If .Value <> "" Then
     rc = Application.Match(False, Range(Cells(2, c.Columns(j).Column + x), "i2"), 0)
      If Not IsError(rc) Then
        .Offset(, rc + x - 1) = Cells(c.Rows(i).Row, c.Cells(j).Column).Value
        .ClearContents
      End If
    End If
   End With
  Next j
Next i
  

End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan