Randomized met kleuren

[Abyss]

Ik heb in Excel een cellen range met nummer er in.
Nu heb ik hier en daar blokjes van twee cellen gekleurd

De gekleurde blokjes wil ik uiteindelijk afgedrukt hebben.

Maar dat is nog niet alles. Ik zou graag willen dat deze kleurtjes randomized over de selectie gaan. Het liefst als ik het werkblad open.
Als de gekleurde vakjes hun positie hebben gevonden zou ik graag willen dat deze in een ander sheetje (blad2) komen te staan, het liefst onder elkaar zodat ik deze kan afdrukken op een sticker.

Heeft iemand een goed idee

Ik heb er een voorbeeld bij gedaan



Abyss

 

[Roncancio]

Een paar vragen:

- Zijn het altijd blokjes van 2? Kunnen het ook losse blokjes zijn bijvoorbeeld?
- Zijn het altijd 6 blokjes van 2 of kunnen het ook meer of minder blokjes zijn?

Met vriendelijke groet,


Roncancio

 

[Abyss]

Een paar vragen:

- Zijn het altijd blokjes van 2? Kunnen het ook losse blokjes zijn bijvoorbeeld?
- Zijn het altijd 6 blokjes van 2 of kunnen het ook meer of minder blokjes zijn?

Met vriendelijke groet,


Roncancio

In deze sheet zijn het 6 blokjes van 2 dit is dan altijd het geval.
Het komt niet voor dat het een blok van 1 is.

Ik heb ook wel sheetjes met 7 of 8 blokken van 2. maar dat komt dan op het zelfde neer.

Abyss

 

[snb]

Sub tst()
  For Each cl In [Blad1!C8:U27]
    If cl.Interior.ColorIndex = 7 Then c0 = c0 & cl.Value & "|"
  Next
  sq = Filter(Split(c0, "|"), " ")
  [Blad2!A20].Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
End Sub

 

[Abyss]

Sub tst()
  For Each cl In [Blad1!C8:U27]
    If cl.Interior.ColorIndex = 7 Then c0 = c0 & cl.Value & "|"
  Next
  sq = Filter(Split(c0, "|"), " ")
  [Blad2!A20].Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
End Sub

Bedankt hiervoor,:thumb:
Echter 1 probleem de keuren veranderen niet, je hebt alleen de gekleurde velden gerandomized.
Ik wil graag dat de kleuren ook random over het werkblad verplaats woorden., Dus iedere keer een ander setje met nummer in kleur.
Die kleur hoeft niet persé als er maar 6 setjes van twee nummer in blad twee worden getoond. De kleur is er eigenlijk aleen voor een visuele weer gave zodat ik snel kan zien dat hij een andere setje nummer kiest en niet telkens dezelfde nummers.


Abyss

 

[LucB]

Komt deze een beetje in de buurt?

 

[Abyss]

Dit is geweldig LucB:thumb::thumb::thumb::thumb::thumb::shocked::shocked::shocked::shocked::shocked:


Echt super bedankt.
En bedankt voor de moeite


Abyss

 

[Roncancio]

Gaarne de vraag op opgelost zetten (rechts onderaan de pagina).
Bvd.

Met vriendelijke groet,


Roncancio

 

[Abyss]

De vraag is opgelost, .


ABYSS

 

[Abyss]

Komt deze een beetje in de buurt?

Hoi LucB

Ik heb toch nog een vraag je m.b.t
de code
Ik wil de area aanpassen (het bereik) maar dat wil hij niet.
heb jij daar nog oplossing voor




Application.ScreenUpdating = False
Sheets(2).Range("A2:A20").ClearContents
Range("A8:Z27").Interior.ColorIndex = xlNone

For n = 1 To 10
x = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
Randomize
nRij = Int(19 * Rnd) + 8
nKol = Int(18 * Rnd) + 3
Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Interior.ColorIndex = 6
Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Copy
Sheets(2).Range("A" & x + 1).PasteSpecial xlPasteValues
Next n

Application.CutCopyMode = False
Application.ScreenUpdating = True

Als ik hert bereik aanpas gebeurt er niet, tenmiste het bereik wordt niet groter.

 

[LucB]

De code is ieta gewijzigd.
Probeer deze maar.

Sub Kleuren()
    Dim nRij As Long, nKol As Long
    Dim n      As Long
    Dim x      As Long

    Application.ScreenUpdating = False
    Sheets(2).Range("A2:A20").ClearContents
    Range("A8:Z27").Interior.ColorIndex = xlNone

    For n = 1 To 6
        x = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
        Randomize
        nRij = Int(19 * Rnd) + 8
        nKol = Int(26 * Rnd) + 1 'deze is aangepast
        Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Interior.ColorIndex = 7
        Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Copy
        Sheets(2).Range("A" & x + 1).PasteSpecial xlPasteValues
    Next n

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Abyss]

De code is ieta gewijzigd.
Probeer deze maar.

Sub Kleuren()
    Dim nRij As Long, nKol As Long
    Dim n      As Long
    Dim x      As Long

    Application.ScreenUpdating = False
    Sheets(2).Range("A2:A20").ClearContents
    Range("A8:Z27").Interior.ColorIndex = xlNone

    For n = 1 To 6
        x = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
        Randomize
        nRij = Int(19 * Rnd) + 8
        nKol = Int(26 * Rnd) + 1 'deze is aangepast
        Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Interior.ColorIndex = 7
        Range(Cells(nRij, nKol), Cells(nRij + 1, nKol)).Copy
        Sheets(2).Range("A" & x + 1).PasteSpecial xlPasteValues
    Next n

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Werkt prima,

Bedankt voor je inzet.

 

[Abyss]

Heb ik nog een laatste vraag.
In sommige kolommen staan minder nummers dan bij andere. Dus de kolommen zijn ongelijk.
Hoe kan ik de range zo aanpassen dat de macro hier toch goed mee om gaat.
Hij zou dus eigenlijk alleen de niet lege cellen in de matrix moeten kleuren.

Zie bijlage

 

[LucB]

Heb dit bestand aangepast.