cellen van een kolommen automatisch samenvoegen op basis van gelijke inhoud

[Gerald Baalhuis]

Beste forum leden,

Is het mogelijk om in een werkmap cellen uit een kolom (A of B) automatisch samen te voegen als deze dezelfde inhoud hebben?
Ik wil eerst de kolommen A t/m .. automatisch sorteren op achtereenvolgens kolom A, dan B, dan G en dan H.
In kolom A kunnen de cijfers 1 t/m 6 (1 = maandag, 2 = dinsdag, enz.) staan. Alle cellen met cijfer 1 moeten samengevoegd worden, daarna alle cellen met het cijfer 2 enz.
Ideaal zou zijn als de celkleur dan ook nog ingesteld wordt. (1 = oranje, 2 = groen, 3 = blauw, 4 = geel, 5 = roze, 6 = paars)
Vervolgens moeten in kolom B de gelijke cijfers samengevoegd worden (9, 13, 14, 17, 23 = tijd als gewoon getal) en gekleuird (9, 13, 14 = lichtblauw, 17 = lichtpaars, 23 = licht oranje)
Zie bijgaand voorbeeld.

Voor het kleuren van de cel dacht ik ook aan voorwaardelijke opmaak, maar kan je de voorwaarden voor voorwaardelijke opmaak ook kopieren naar een ander werkblad/map?
We gebruiken nl. een schema van 4 weken van elk 6 dagen (week A t/m D en maandag t/m zaterdag). In totaal dus 28 werkmappen met elk voor elke afdeling (3 stuks) 3 werkbladen.

Zie bijgaand voorbeeld voor o.a. de kleuren.

Met vriendelijke groet,

 

[wampier]

Hoe bedoel je samengevoegd? tot 1 grote cel? Overigens kloppen de kleuren uit je text niet met het voorbeeld, maar de kleuren an sich is nog wel te doen met standaardcijfers.

 

[Gerald Baalhuis]

Wampier,

Ik bedenk mij nu dat het nog iets ingewikkelder is:
Alle cellen met het cijfer 1 in kolom A samenvoegen tot één cel als het cijfer in kolom B 17 is en alle cellen met waarde 17 in kolom B samenvoegen tot één cel.
Alle cellen met het cijfer 1 in kolom A samenvoegen tot één cel als het cijfer in kolom B 23 is en alle cellen met de waarde 23 in kolom B samenvoegen tot één cel.
Enzovoorts voor cijfer 2 in kolom A, cijfer 3 in kolom A.

Overigens komen er per werkdag maximaal 3 dagnummers voor in kolom A. Maandag (1) kan er dus voor maandag (1), disndag (2) of woensdag (3).
Dinsdag (2) voor dag 2,3 of 4 enz.

De kleuren zouden moeten zijn:
Maandag = oranje
Dinsdag = groen
Woensdag = Blauw
Donderdag = geel
Vrijdag = Roze
Zaterdag = Paars

9, 13, 14 u = lichtblauw
17 u= lichtpaars
23 u = lichtoranje

Is dit wat duidelijker? Als je meer info nodig hebt, please let me know!

Alvast bedankt voor het meedenken.

Groet,

Gerald

 

[wampier]

zo? (kleuren is nog niet gedaan, maar het gaat me even om de merge)

Sub blokken()
Application.DisplayAlerts = False
Dim begin As Range
Dim eind As Range
Set begin = Sheets("MAL").[B3]
Set eind = LookAhead(begin.Value, begin)
While eind.Offset(1).Value <> ""
    ActiveSheet.Range(begin, eind).Merge
    ActiveSheet.Range(begin.Offset(0, -1), eind.Offset(0, -1)).Merge
    Set begin = ActiveSheet.Range(eind.Offset(1), eind.Offset(1))
    Set eind = LookAhead(begin.Value, begin)
Wend
ActiveSheet.Range(begin, eind).Merge
ActiveSheet.Range(begin.Offset(0, -1), eind.Offset(0, -1)).Merge
Application.DisplayAlerts = True
End Sub

Function LookAhead(waarde As String, startlocatie As Range) As Range
Dim einde As Range
Dim cell As Range
Set einde = startlocatie.Offset(300000).End(xlUp)

For Each cell In ActiveSheet.Range(startlocatie, einde)
    If cell.Value <> waarde Then
        Set LookAhead = cell.Offset(-1)
        Exit For
    End If
Next cell

If LookAhead Is Nothing Then
    Set LookAhead = einde
End If
End Function

 

[Gerald Baalhuis]

Wampier,

Het in perfect!!! Dank, dank, dank....
Nu nog de kleurtjes..

Gerald

 

[wampier]

Klein beetje gecheat omdat je een aantal niet-standaard kleuren gebruikt.

Sub blokken()
Application.DisplayAlerts = False
Dim begin As Range
Dim eind As Range
Set begin = [B3]
Set eind = LookAhead(begin.Value, begin)
ActiveWorkbook.Colors(47) = RGB(112, 48, 160)
ActiveWorkbook.Colors(15) = RGB(178, 161, 199)

While eind.Offset(1).Value <> ""
    kleurkeuze = Abs((begin.Value < 17) * 1 + (begin.Value = 17) * 2 + (begin.Value = 23) * 3)
    Range(begin, eind).Interior.ColorIndex = Choose(kleurkeuze, 37, 15, 40)
    Range(begin, eind).Merge
    Range(begin.Offset(0, -1), eind.Offset(0, -1)).Interior.ColorIndex = Choose(begin.Offset(0, -1).Value, 44, 14, 33, 6, 7, 47)
    Range(begin.Offset(0, -1), eind.Offset(0, -1)).Merge
    Set begin = Range(eind.Offset(1), eind.Offset(1))
    Set eind = LookAhead(begin.Value, begin)
Wend
    kleurkeuze = Abs((begin.Value < 17) * 1 + (begin.Value = 17) * 2 + (begin.Value = 23) * 3)
    Range(begin, eind).Interior.ColorIndex = Choose(kleurkeuze, 37, 15, 40)
    Range(begin, eind).Merge
    Range(begin.Offset(0, -1), eind.Offset(0, -1)).Interior.ColorIndex = Choose(begin.Offset(0, -1).Value, 44, 14, 33, 6, 7, 47)
    Range(begin.Offset(0, -1), eind.Offset(0, -1)).Merge
Application.DisplayAlerts = True
End Sub

Function LookAhead(waarde As String, startlocatie As Range) As Range
Dim einde As Range
Dim cell As Range
Set einde = startlocatie.Offset(300000).End(xlUp)

For Each cell In Range(startlocatie, einde)
    If cell.Value <> waarde Then
        Set LookAhead = cell.Offset(-1)
        Exit For
    End If
Next cell

If LookAhead Is Nothing Then
    Set LookAhead = einde
End If
End Function

 

[Gerald Baalhuis]

Wampier,

Helemaal fantastisch!!

Nogmaals mijn dank.

Met vriendelijke groet,

Gerald