Rij selecteren met vba code adhv kleur

[rg027]

Beste,

Als een cel in kolom E de gele kleur heeft welke vba code dien ik te gebruiken om de rij waarin de gekleurde cel zich bevind te selecteren en te kopieren?

Alvast bedankt

 

[Ruudjuh®]

je wilt dus de gehele inhoud kopiëren?

 

[Spiderman]

Hoi rg027,

Ik zou het zo doen:

Sub CopyByColor()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("E1:E" & LastRow)
    If r.Interior.Color = vbYellow Then
        CopyRow = r.Row
        Range(CopyRow & ":" & CopyRow).Copy
        ' -------------------------------------------
        ' Plakken op blad 2 Kolom A
        X = X + 1
        Sheets("Blad2").Range("A" & X).PasteSpecial
        ' -------------------------------------------
    End If
Next

End Sub

Suc6

 

[Wigi]

Hallo

Ik zou dit nemen:

Sub CopyByColor()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("E1:E" & LastRow)
    If r.Interior.ColorIndex = 6 Then
        r.EntireRow.Copy
        Sheets("Blad2").Range("A" & X + 1).PasteSpecial
    End If
Next
End Sub

Wigi

 

[Spiderman]

@ Wigi

Werkt idd mooier.

r.EntireRow.Copy

Maar bij deze ben je vergeten dat X moet worden opgeteld (x=x+1)

Sheets("Blad2").Range("A" & X + 1).PasteSpecial

 

[Wigi]

Maar bij deze ben je vergeten dat X moet worden opgeteld (x=x+1)

Klopt Arno. Bedankt.

Sub CopyByColor()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("E1:E" & LastRow)
    If r.Interior.ColorIndex = 6 Then
        r.EntireRow.Copy
X = X+1
        Sheets("Blad2").Range("A" & X).PasteSpecial
    End If
Next
End Sub

 

[rg027]

Hartelijk bedankt voor deze mooie code.

Is het ook mogelijk indien het een voorwaardelijke opmaak is deze te knippen en te plekken in een blad? Heb geprobeert met een voorwaardelijke opmaak bvb als de cel "ok" bevat deze te kleuren in het geel (dat lukt) maar bij het uitvoeren van de macro neem deze de rij niet mee

 

[Wigi]

Hartelijk bedankt voor deze mooie code.

Is het ook mogelijk indien het een voorwaardelijke opmaak is deze te knippen en te plekken in een blad? Heb geprobeert met een voorwaardelijke opmaak bvb als de cel "ok" bevat deze te kleuren in het geel (dat lukt) maar bij het uitvoeren van de macro neem deze de rij niet mee

VBA code voor Conditional formatting is vrij moeilijk. Zie hier bij Chip Pearson voor wat je evt. kan doen. Maar gemakkelijk is het dus niet.

Wigi

 

[rg027]

Zonder voorwaardelijke opmaak dan maar en zonder kleur. dus als de cel de waarde ok bevat gewoon de rij knippen en deze plakken op andere plaats? is dat makkelijker ? het is de bedoeling deze te plakken in het zelfde blad bvb vanaf cel a3
Ken niks van vba dus........

Toch al bedankt voor je hulp hoor

 

[rg027]

Wigi (of andere),

Ik heb zelf een poging gedaan om cellen leeg te maken met de code van u. Het is nu zo dat ik de macro verschillende malen moet doen werken voor alle cellen leeg zijn. Waar zit het foutje wat moet aangepast worden?

Sub Maakcellenleeg()
'

'
Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("E1:E" & LastRow)
If r.Interior.ColorIndex = 6 Then
r.EntireRow.Delete
X = X + 1
End If
Next
End Sub

 

[Spiderman]

Hoi rg027,

Als je een rij verwijderd dan schuift de rij eronder 1 naar boven. Dus als je bijvoorbeeld rij4 verwijderd, dan schuift rij5 één omhoog en wordt deze rij4.

Als je met een For Each werkt dan gaat deze van bijvoorbeeld 1 naar 10.

Als rij4 dus wordt verwijderd en rij5 omhoog gaat, wordt de verplaatste rij niet opnieuw getest.

Wat je dus moet doen is van onder naar boven werken, zoals in onderstaande voorbeeld:

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For X = LastRow To 1 Step -1
    If Range("E" & X).Interior.ColorIndex = 6 Then
        Range("E" & X).EntireRow.Delete
    End If
Next X

Suc6

 

[rg027]

Dat is het inderdaad.Hartelijk bedankt
Nooit te oud om bij te leren zie je maar

groeten rg027