Zoek veldkleur in volledige excelbestand en verwijder alle kolommen daarvan

Status
Niet open voor verdere reacties.
L

Lerac

Gebruiker
Lid geworden
13 apr 2007
Berichten
26
Halllo allemaal,

Ik zou graag een macro willen om in een werkboek met meerdere bladen te zoeken naar cellen die een bepaalde RGB kleurcode (bij voorkeur meer dan 1 kleur te kunnen zoeken) hebben en daar waar deze voorkomen de kolommen (let op niet rijen) te verwijderen. De kleur kan overal voorkomen en let op het dient de hele kolom te verwijderen niet de cell alleen. Ik heb al een script gevonden na heel lang zoeken. Maar verveldende ervan is:

1. Hoe groter de range de meer het vastloopt (bij 1000 heeft het al wat laadtijd nodig in 1 blad
2. Werkt alleen in actieve sheet bij draaien van script
3. Er kan maar gezocht worden op 1 kleur
4. Error 1004 command cannot use overlapping selections als je dezelfde rgb kleurcode meer dan 1 keer in de zelfde kolom hebt staan.

Dit is de script die ik tot op heden heb:
Code: 
Sub SelectColoredCells()
    Dim rCell As Range
    Dim lColor As Long
    Dim lColor2 As Long
    Dim rColored As Range


    'Select the color by name (8 possible)
    'vbBlack, vbBlue, vbGreen, vbCyan,
    'vbRed, vbMagenta, vbYellow, vbWhite
    'lColor = vbBlue


    'If you prefer, you can use the RGB function
    'to specify a color
    Range("A1:Q1000").Select
    
    lColor = RGB(68, 114, 196)


    Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.EntireColumn.Delete
        End If
    Set rCell = Nothing
    Set rColored = Nothing
End Sub

Wellicht is er een betere oplossing of kan iemand me helpen met uitbreiden van mijn huidige code.
 
Bv.
Code: 
Sub hsv()
Dim sh As Worksheet, cl As Range, arr, j As Long 'declareren van de variabelen
For Each sh In Sheets  'loop alle sheets bijlangs
 For Each cl In sh.Range("a1:q1000") 'loop alle cellen af van "sh"
   arr = Array(RGB(255, 0, 0), RGB(0, 255, 0))  'welke kleuren zijn er
       For j = 0 To UBound(arr) 'kijk of elke cel de kleur bevat van de For
        If cl.Interior.Color = arr(j) Then cl.EntireColumn.Delete  'klopt de kleur, verwijder de kolom met die kleur
       Next j  'volgende kleur controle
     Next cl   'volgende cel controle
   Next sh     'volgende blad in je werkboek
End Sub
 
Bedankt HSV dat je de tijd neemt om mij te helpen. Ben er al een tijdje mee aan het stoeien. Jij lijkt deze dingen zo uit je losse mouw te kunnen gooien.

Helaas krijg ik bij draaien van "error runtime error 424 object required"

Heb in mijn sheet 2x in dezelfde kolom de eerste kleurkeuze laten voorkomen 255,0,0 en los nog in een paar andere en dit resulteert in foutmelding. Hetzelfde gebeurd ook als ik maar 1 cell willekeurige locatie die RGB kleur gegeven heb.

Aanvullend vroeg ik me af of ik verplicht een range dien aan te geven. Heb dat namelijk liever niet omdat ik de macro in de hele sheet wil laten zoeken. Voor excel voor 2007 was het maximum IV65536 en er is nog 1 die hoger is voor excel 2007 en hoger. Probleem echter (heb ik nog niet met jouw macro getest) is hoe hoger ik dit instel dat excel not responding ga krijgen omdat het natuurlijk 1 voor 1 elke cell afgaat
 
Laatst bewerkt door een moderator:
Plaats anders een bestandje met hoe het eruit ziet.
Bevatten bv. de gekleurde cellen ook waarden of formules, of zijn ze verder leeg?
Dus een zo gelijkend mogelijke voorbeeld als je wilt.
 
Er maar vanuit gaande dat de cellen net zo goed geen waarde kan bevatten, omdat er gekozen is voor de kolomletter in de gekleurde cellen.
Dient zeker ter controle?
Code: 
Sub hsv()
Dim sh As Worksheet, cl As Range, arr, j As Long, c As Range 'declareren van de variabelen
Application.ScreenUpdating = False
For Each sh In Sheets  'loop alle sheets bijlangs
 For Each cl In sh.UsedRange.Cells 'loop alle cellen af van "sh"
   arr = Array(RGB(255, 0, 0), RGB(191, 191, 191))  'welke kleuren zijn er
       For j = 0 To UBound(arr) 'kijk of elke cel de kleur bevat van de For
        If cl.Interior.Color = arr(j) Then
             y = y + 1
          If y = 1 Then
            Set c = cl.EntireColumn
           Else
            Set c = Union(c, cl.EntireColumn)
          End If
         End If
       Next j  'volgende kleur controle
     Next cl 'volgende cel controle
     c.EntireColumn.Delete
     Set c = Nothing
     y = 0
   Next sh     'volgende blad in je werkboek
End Sub
 
Weer een snelle oplossing van je, bedankt! De kolom met letter erin zullen altijd een tekstwaarde bevatten ongeacht er een kleur in zit of niet. Maar kennelijk werkt het zo ook fantastisch. Ga het nog wat uitgebreider testen, maar zo te zien heb je me flink op weg geholpen. Nogmaals dank!
 
Laatst bewerkt door een moderator:
Als er altijd een waarde staat, en veel lege cellen kan het sneller door....

Code: 
For Each cl In sh.UsedRange.Cells 'loop alle cellen af van "sh"

....te vervangen door.

Code: 
For Each cl In sh.cells.specialcells(2)   'loop alle cellen af die een waarde bevatten van "sh"
 
Is het ook mogelijk om ipv RGB een bepaalde PatternColor code tegebruiken?

En bedankt voor de tips voor snellere verwerking
 
Beste Lerac,

Ik heb wat quotes van u weggehaald. Als u direct reageert op de vorige post hoeft u geen quote te gebruiken :)

Succes met de vraag en een prettige dag verder :thumb:
 
Waarom, wanneer en waarvoor worden kleuren gebruikt ?
 
Excuus mastermindzh zal dit niet meer doen. Deed het automatisch.

Initieel wordt er een excel bestand opgesteld zoals in voorbeeld.xlsx. Hierbij krijgen de kolommen expliciete kleurcodes. Dit overzicht wordt apart bewaard. Nadat dit afgerond is wil ik met een macro in dit overzicht laten zoeken naar die expliciete kleurcodes om deze kolommen te verwijderen en vervolgens weer als apart excel bestand op te slaan. Er zijn dus meerdere tabellen in 1 sheet en meerdere sheets met meerdere tabellen aanwezig. De regel waarin de tabelheaders zijn kunnen verschillende zijn. Het kan in rij 10 of rij 14 zijn. Eigenlijk is de eerste tabel relevant alleen zoals in voorbeeld omdat je uiteraard geen kolommen kan verwijderen waarbij 2 tabellen onder elkaar zijn die verschillen.

De script zoals geleverd werkt nog neit helemaal gek genoeg wel voor de al ingestelde kleur maar ik zou ook nog RGB in een hex kleurcode bijv. 37F56A en 82BAFE willen veranderen van het script.

Addtioneel valt het me op als ik de kleurcode RGB verander naar arr = Array(RGB(130, 186, 254), RGB(55, 245, 106) en bepaalde cellen die expliciete kleur geef dat ik foutmeldg "Run-time error '91' Object variable or With block variable not set" krijg. Misschien omdat 1 van de 2 kleuren niet voorkomen? In een sheet waar geen van de kleuren voorkomen krijg ik met de geleverde code ook de error.

Bedankt voor de vragen en hulp
 
Laatst bewerkt:
Plaats het bestand eens.
De RGB kleuren zijn gemakkelijker te vinden dan de pattern kleur.
Klik op een cel, eigenschappen, opvulling, meer kleuren, aangepast, en daar staat je RGB.
 
Heb dezelfde sheet met aangepaste kleur en exact zelfde code maar uiteraard met de RGB kleuren ipv de kleurcodes. Bekijk bijlage Voorbeeld 2.xlsm . Deze zal dus resulteren in de error

Reden waarom ik hex wil is omdat dit algemeen gehanteerd wordt bij alles en niet RGB. Maar goed als alleen RGB kan is het niet anders en zal ik werkwijze moeten aanpassen. Bedankt voor de stappen om bij de RGB kleuren te komen. Had het al gezien maar aangezien ik geen hex zag dacht ik laat ik vragen of het mogelijk is.

Overigens als ik end bij error klikt verwijderd het wel netjes alle kolommen die verwijderd dienen te worden.

Bedankt zoals altijd.
 
Laatst bewerkt:
Deze regel (bijna onderaan) even aanpassen.
Code: 
[COLOR=#ff0000]If Not c Is Nothing Then [/COLOR]c.EntireColumn.Delete
 
Zet in de kolommen die verwijderd moeten worden in rij 1 een comment.

Daarna is deze code voldoende:

Code: 
Sub M_snb()
  Rows(1).SpecialCells(-4144).EntireColumn.Delete
End Sub
 
Super werkt als een trein maar dan zonder die vervelende storingen :)

Oh ik zie nu dat snb een andere optie geeft dan HSV. Beiden goed?
 
Laatst bewerkt:
Ik ga ervan uit dat beide suggesties uiteindelijk werkten.

Had toch nog een additionele vraag. Kan ik in dat veld met de kleur aangeven dat het ook verplicht met "out:" dient te beginnen om de kolom te verwijderen. Dus zeg maar simpelweg:

- Indien het 1 van die kleuren heeft EN begint met de tekst "out:"

Nogmaals dank. En de script werkt uitstekend.
 
Mij lijkt het veel eenvoudiger met 1 dubbelklik een comment toe te voegen aan de cel in rij 1 van de kolom die uiteindelijk verwijderd moet worden:

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Row = 1 And Target.Comment Is Nothing Then
    Target.AddComment
     Cancel = True
  End If
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan