• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Kleur sneller wijzigen met macro (maar liefst nóg sneller)

Status
Niet open voor verdere reacties.
G

gGerretje

Gebruiker
Lid geworden
12 mrt 2008
Berichten
439
Beste helpers,

In mijn gegevensbestand heb ik een aantal regels en cellen opgemaakt met een kleurtje om de zaak wat te verduidelijken en te verfraaien.
Ik kan nu met een druk op de knop regelen dat alle cellen binnen het opgegeven bereik (A3:S5000) die dezelfde achtergrondkleur hebben als cel J1, de achtergrondkleur van J2 krijgen.
Vervolgens hoef ik alleen de cellen J1 en J2 te wijzigen om ook andere kleuren aan te passen in plaats van door in mijn hele werkblad steeds regel voor regel en cel voor cel te moeten aanpassen.

Bijgaande code werkt voor zover ik kan nagaan.
Code: 
Private Sub btn_TekstWijzigen_Click()
    Dim rng As Range, cell As Range
    
    Set rng = Range("A3:S5000")
    For Each cell In rng
        If cell.Interior.Color = Worksheets("België").Range("J1").Interior.Color Then
            cell.Interior.Color = Worksheets("België").Range("J2").Interior.Color
        End If
    Next cell
End Sub

Mijn hele werkblad (een overzicht van brouwerijen en biermerken voor mijn verzameling bier-etiketjes) bevat dus meer dan 5000 regels.
Dat gaat erg traag. Kan ik de zaak nog op een of andere manier versnellen?

Alvast bedankt voor jullie hulp.

Ger
 
Code: 
Private Sub btn_TekstWijzigen_Click()
Application.ScreenUpdating = False
    Dim rng As Range, cell As Range
    
    Set rng = Range("A3:S5000")
    For Each cell In rng
        If cell.Interior.Color = Worksheets("België").Range("J1").Interior.Color Then
            cell.Interior.Color = Worksheets("België").Range("J2").Interior.Color
        End If
    Next cell
Application.ScreenUpdating = True
End Sub

Application.screenupdating helpT vaak al genoeg
 
Laatst bewerkt:
Hallo Sjon,

Stom van mij. Had ik moeten weten. Ik ben hem nog tegengekomen toen ik een tijd geleden die hele dikke handleiding heb doorgeploegd.
Dit helpt al een stuk.
Bedankt voor je tip.

Heeft iemand nóg een extra versnelling?
 
Probeer deze eens:
Code: 
Sub Kleurtjes()
    Dim rCell As Range, rColored As Range, lColor1 As Long, lColor2 As Long
    
    With Worksheets("België")
        lColor1 = .Range("J1").Interior.Color
        lColor2 = .Range("J2").Interior.Color
    End With
    
    For Each rCell In Range("A3:S5000")
        If rCell.Interior.Color = lColor1 Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If Not rColored Is Nothing Then rColored.Interior.Color = lColor2
End Sub
 
Laatst bewerkt:
Of:
Code: 
Sub hsv()
Dim j As Long, Scolor
Application.ScreenUpdating = False
 For j = 1 To 19
 Scolor = Cells(5501, j).Interior.Color
    With Range("a3:S5500").Columns(j)
        .AutoFilter 1, Range("J1").Interior.Color, xlFilterCellColor
         AutoFilter.Range.Offset(1).SpecialCells(12).Interior.Color = Range("J2").Interior.Color
        .AutoFilter
     End With
  Cells(5501, j).Interior.Color = Scolor
 Next j
End Sub
 
Laatst bewerkt:
Hallo Ed,

Dat gaat echt veel sneller.
We gaan van 30 naar 12 seconden. De moeite waard dus.

Bedankt.

Ik ga nu die van Harry uitproberen
 
Hallo Harry,

Ik krijg een foutmelding (424, Object vereist) op de tweede regel in de With ... End With.
De punt had ik er al voor gezet.
 
Laatst bewerkt:
Hallo Ger,

Filteren op kleur is vanaf Excel 2007; of het in de nieuwere versies zit weet ik niet.
Oudere versie werkt dus niet.
 
Werkt hier feilloos, misschien kun je het bestand plaatsen, en waarom is die range zo groot (55000 rijen, uit voorzorg?).
Als dat zo is kun je er beter een tabel van maken, zo heb je altijd de juiste range.
 
Er staat S5000, niet 55000 ;)
 
Mijn excuus, dan overal een nulletje verwijderen.

Ps. Ik heb de code aangepast.
 
Laatst bewerkt:
Hallo Harry,

Het zijn er 5000. A1:S5000
Ik verzamel bier-etiketten.
Op dit blad staan de Belgische brouwerijen met al hun biersoorten.
Niet dat ik al die etiketten heb, maar ze staan erin zodat ik ze kan aanvinken als ik ze heb.
In totaal nu al zo'n 4500 regels.

Bekijk bijlage KleurenWijzigenMetMacro.xlsm
 
Die punt die jezelf hebt toegevoegd die moet daar weg.

Of beter; maak het zo!
Code: 
.Offset(1).SpecialCells(12).Interior.Color = Range("J2").Interior.Color
 
Laatst bewerkt:
waarom gebruik je geen voorwaardelijke opmaak ?

bijv. alle van J1 afhankelijke cellen een kleur toekennen op grond van bijv. =$J$1=12

als de waarde van J1 12 wordt, verschieten al die cellen van kleur.
 
Laatst bewerkt:
Hallo snb,

De gekleurde vakken zijn de namen van de brouwerijen.
Sommigen zijn al jaren gesloten (achtergrond rood) anderen brouwen zelf niet (groene achtergrond).
Ik kan ze dus niet afhankelijk maken van J1.
 
Je flikt het weer hè Harry.
ongeveer 3 seconden

Alleen gaat de code me nu wel een beetje boven mijn pet. :rolleyes:

Bedankt voor je hulp.
Veel sneller zal het toch niet meer kunnen?
 
Van 30 seconden naar 12 naar 3.
En je wilt nog sneller? ;)
 
Geen idee.

Maak het eens zo.
Code: 
.Offset(1).Interior.Color = Range("J2").Interior.Color

Dat met die specialcells zit er nog zo ingebakken van eerdere tijden.
 
Hallo Ed,

Nee hoor. Absoluut niet. Ik ben dik tevreden.
Maar het lijkt wel alsof jullie er een sport van maken. Vandaar die laatste opmerking.
Ik hou het zelfs niet bij met al jullie reacties.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan