zoeken naar celkleur en rijen verwijderen

[bebobebo]

Beste,

Ik heb een stukje macro die zoekt in een kolom vanaf de cursor naar de volgende waarde
in een cel en haalt dan de tussen liggende regels weg , dit werkt.
Ik wil nu dat hij zoekt naar een cel met een opvulkleur zwarte i.p.v. een waarde.

Sub legeruimteweg2()

With Selection.Interior
        .ColorIndex = 2
        '.Pattern = xlSolid
    End With
AllRows = Range("c65536").End(xlUp).Row
                LegeRijen = 0
                For i = AllRows To 1 Step -1
                    If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
                        Selection.Rows(i).EntireRow.Delete
                        LegeRijen = LegeRijen + 1
                    End If
                    AllRows = AllRows - 1
                Next i
       Range("c12").Select
    
End Sub

Bovenstaande code heb ik geleend van verschillende vragen en is niet de mooiste en de snelste geworden.
Dit is mijn max binnen vba.

Wie kan mij verder helpen.

Gr. Bert

 

[HSV]

Vanaf Excel 2007 kan je filteren op kleur.
Erg snel.
Het bereik is a1:c10 en de filter staat op kolom 1 met de RGB-kleur op zwart.
Test het in een testbestand.

Sub hsv()
With Sheets("Blad1")
 Blad1.Range("A1:C10").AutoFilter 1, RGB(0, 0, 0), xlFilterCellColor
    .AutoFilter.Range.Offset(1).EntireRow.Delete
    .Range("A1:C10").AutoFilter
 End With
End Sub

 

[bebobebo]

Hallo Harry,

Dank voor je reactie.
Ik ben niet helemaal duidelijk geweest denk ik.
Ik wil graag het volgende:

in kolom c moet de waarde in de kolom blijven staan.
zet cursor op c12 en laat macro lopen
macro haalt nu lege regels weg tussen cursor en eers volgende waarde in kolom c
Ik wil nu de macro zo hebben dat hij niet de eerst volgende waarde zoekt naar het eertse zwarte vlak

De nieuwe macro zal dus moeten werken met de data die in kolom p staat

Ik doe er even een bestandje bij, hoop dat het zo duidelijk is.

 

[HSV]

Test het eens Bert.
Je hoeft geen cel te selecteren, gewoon de code laten lopen.

Sub hsv()
Dim y As Long, Frow As Long, Lrow As Long
Application.ScreenUpdating = False
With Sheets("Blad1")
    .Columns(15).AutoFilter 1, RGB(0, 0, 0), 8
  Lrow = .Range("O2:O1000").SpecialCells(12).Range("A1").Row
    .Columns(15).AutoFilter
  Frow = .Columns(3).CurrentRegion.Rows.Count
    .Range("O" & Frow & ":O" & Lrow - 2).AutoFilter 1, "=", , , False
  On Error Resume Next
    .AutoFilter.Range.SpecialCells(4).EntireRow.Delete
    .Range("O" & Frow & ":O" & Lrow - 2).AutoFilter
  End With
End Sub

 

[bebobebo]

Harry, dank voor je reactie.
De code loopt nu over blad 1, moet over de actieve sheet gaan lopen.
Selecteren van een cel is wel nodig, stel dat er geen waarde staat in bijvoorbeeld o2, dan moet deze lege cel wel blijven staan.
Kan je hier wat mee?

Gr. Bert

 

[HSV]

Zou je een situatie in een bestandje kunnen maken waarin dit zou kunnen gebeuren Bert.

 

[bebobebo]

Als je de cursor op c24 zet moeten de rijen vanaf c24 tot c31 weg, zwarte rij moet blijven.
Alle rijen boven C24 moeten t/m c1 helemaal in takt blijven.

 

[HSV]

Zou dit wat kunnen zijn ?
De activecell direct onder de laatste waarde plaatsen van kolom C.
Of de apostrof weghalen in de code.

Sub hsv()
With ActiveSheet
 'Application.Goto Cells(Rows.Count, 3).End(xlUp).Offset(1)
 .Range(ActiveCell, .Columns(12).SpecialCells(-4123).End(xlDown)).EntireRow.Delete
End With
End Sub

 

[bebobebo]

Beste Harry,

Helemaal top, hier kan ik wat mee, best wel slim om kolom 12 te gebruiken.
Heel veel dank voor de moeite, hartelijk dank voor de tijd die je genomen heb om mij te helpen.


Gr. Bert