ingekleurde cellen automatisch kopiëren naar nieuw tabblad

[Anke1983]

Dag iedereen,

Iemand die me kan helpen? Graag had ik van het ene werkblad de gekleurde cellen automatisch gekopieerd naar het ander werkblad...

Het zou de bedoeling zijn dat leerlingen die cellen opvullen met een bepaalde kleur (geel) om zo te zien verschijnen in een overzicht (tabel) op een volgend werkblad...

Is dit mogelijk? ;-)

Alvast bedankt voor de hulp!

 

[gast0660]

Beste Anke, welkom op het forum
Post eens een gelijkend voorbeeld bestand met het gewenst resultaat (handmatig), dan wordt je sneller en gerichter geholpen.
Mijn glazen bol heeft mijn vrouw in de glascontainer gekiepert.

 

[edmoor]

Dus je vrouw ligt nu in de glascontainer???
Die glazen bol toch!

 

[SjonR]

De glazen bollen van tegenwoordig

 

[gast0660]

Wijsneuzen:d
Ik word hier toch altijd direct afgeslacht.

 

[SjonR]

terwijl de Vlamingen altijd wonnen met Tien voor Taal....

 

[gast0660]

terwijl de Vlamingen altijd wonnen met Tien voor Taal....

Je moet er niet veel achter zoeken, de oorzaak is een paar Brugse zotten op een heel warm terras in Antwerpen
Moest je niet weten wat een Brugse zot is, den ED weet dat ook niet meer na een dozijn of zo.
Tien voor Taal winnen we nog altijd zonder verpinken.
Wees voorzichtig dat we Anke geen schrik bezorgen, ze is een newbie.

 

[SjonR]

we wachten het voorbeeld van Anke rustig af...:thumb:

 

[Anke1983]

Dag heren
Ik had graag van werkblad 3 (leerplandoelen) de leerplandoelen die de lln aanduiden in het 'geel' gekopieerd gezien in het werkblad 'evaluatie', in tabelvorm (dus onder elkaar)... Ik weet niet of dit zal lukken, maar ik vermoed dat ik nog niet alles van excel afweet Er staan nog geen leerplandoelen in, da's voor later, maar moest er dus een systeem bestaan, hoor ik het graag! Merci!

 

[Anke1983]

ohja

 

[Anke1983]

En nu een voorbeeld van hoe ik graag zou willen dat het er uit ziet

PS: ik kan tegen veel hoor, die Brugse zotten zijn mij niet onbekend

 

[SjonR]

is dit wat je zoekt?

 

[Anke1983]

Ja!! Super! Bedankt!!
Mag ik je vragen hoe je dit voor elkaar gekregen hebt? Ongelofelijk bedankt ;-)

:thumb:

 

[SjonR]

dat mag uiteraard.

Dit stukje VBA staat achter je tabblad "Leerplandoelen".

Private Sub Worksheet_Deactivate()
With Sheets("EVALUATIE")
    LR = .Columns(1).Find("Attitudes").Row
    If LR > 3 Then
        .Range("A3:A" & LR - 1).EntireRow.Delete xlShiftUp
    End If
        For Each cl In Range("A8:D33")
            LR = .Columns(1).Find("Attitudes").Row
            If cl.Interior.Color = 65535 Then
                .Rows(LR).Insert
                .Cells(LR, 1).Value = cl.Value
                .Cells(LR, 1).Interior.Color = cl.Interior.Color
            End If
        Next
End With
End Sub

Dat kan je zien door met je R-Muisknop op het tabblad te klikken en daarna op "Programmacode weergeven". oF ALT+ F11 en dan klikken op het tabblad Leerplandoelen

 

[Anke1983]

Amai... Ik ben onder de indruk! Bedankt hoor!!

 

[SjonR]

Amai? Ook een Vlaming? Haha

 

[Anke1983]

Amai Ja hoor!

Nog een vraagje... Ik heb meerdere lijnen toegevoegd... maar de laatste neemt hij niet mee in het overzicht. Kan ik dit zelf aanpassen?

 

[SjonR]

dan denk ik dat je het rode getal (rijnummer) even moet ophogen

Private Sub Worksheet_Deactivate()
With Sheets("EVALUATIE")
    LR = .Columns(1).Find("Attitudes").Row
    If LR > 3 Then
        .Range("A3:A" & LR - 1).EntireRow.Delete xlShiftUp
    End If
        For Each cl In Range("A8:D[COLOR="#FF0000"]33[/COLOR]")
            LR = .Columns(1).Find("Attitudes").Row
            If cl.Interior.Color = 65535 Then
                .Rows(LR).Insert
                .Cells(LR, 1).Value = cl.Value
                .Cells(LR, 1).Interior.Color = cl.Interior.Color
            End If
        Next
End With
End Sub

 

[Anke1983]

:thumb:

Super! Bedankt! Nu kan ik verder!!

 

[HSV]

Application.Match is sneller.
Wat als 'Attitudes' er niet instaat?
Je weet dat je weer op rij 3 wilt beginnen, dan hoef je niet weer te zoeken naar 'Attitudes' (gewoon een tellertje i.p.v.)

Private Sub Worksheet_Deactivate()
With Sheets("EVALUATIE")
    LR = Application.Match("Attitudes", .Columns(1), 0)
    If Not IsError(LR) Then
    If LR > 3 Then .Range("A3:A" & LR - 1).EntireRow.Delete
     y = 2
        For Each cl In Range("A8:D33")
            If cl.Interior.Color = vbYellow Then
                y = y + 1
                .Rows(y).Insert
                .Cells(y, 1).Value = cl.Value
                .Cells(y, 1).Interior.Color = cl.Interior.Color
            End If
        Next
        End If
End With
End Sub