• 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.

aktie op kleuren van een cel

Status
Niet open voor verdere reacties.
Roncancio zei:
Ja, dat kan.
Zijn dat de enige kleuren die je gebruikt, of gebruik je ook kleuren die niet gekopieerd moeten worden?

Met vriendelijke groet,
Roncancio
Klik om te vergroten...

Ik denk wel dat dat voorlopig de enige kleuren zijn, wellicht nog een derde kleur in de toekomst:)
Ik gebruik geen kleuren om niet te kopieren.
 
Code: 
Dim sLoc As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If IsError(Workbooks("geel2.xls")) Then
    MsgBox "Bestand is niet geopend.", vbExclamation, "File niet open."
Else
    If Not sLoc = "" Then
        If Range(sLoc).Interior.ColorIndex [B][COLOR="red"]> 0[/COLOR][/B] Then Range(sLoc).EntireRow.Copy Workbooks("geel2.xls").Worksheets(3).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
    sLoc = Target.Address
End If

End Sub
Alleen het rode gedeelte is aangepast.
De code werkt nu voor alle kleuren.

Met vriendelijke groet,


Roncancio
 
Helemaal TOP:thumb::thumb:

één klein vraagje nog:o
Nu kopieert ie pas als je de cel verlaat die je gekleurd hebt. Kan je het ook laten kopieren zodra de cel een kleur heeft gehad?
Ben bang dat je anders bij je laatste aktie vergeet de cursor uit de laatst gekleurde cel te halen.
 
vrouw zei:
Helemaal TOP:thumb::thumb:

één klein vraagje nog:o
Nu kopieert ie pas als je de cel verlaat die je gekleurd hebt. Kan je het ook laten kopieren zodra de cel een kleur heeft gehad?
Ben bang dat je anders bij je laatste aktie vergeet de cursor uit de laatst gekleurde cel te halen.
Klik om te vergroten...

Het veranderen van de layout van een cel zorgt er niet voor dat een Change Event wordt geactiveerd.

Met vriendelijke groet,


Roncancio
 
@Roncancio

Op zich werkt deze code heel mooi maar ik heb soms wel dat ie de regels 3 of 4 keer onderelkaar aanmaakt.
Is dat simpel te ondervangen?:o

En dat gebeurt met name als je eerst een kleur gebruikt hebt en dezelfde regel later een andere kleur geeft.
 
Laatst bewerkt:
vrouw zei:
@Roncancio

Op zich werkt deze code heel mooi maar ik heb soms wel dat ie de regels 3 of 4 keer onderelkaar aanmaakt.
Is dat simpel te ondervangen?:o

En dat gebeurt met name als je eerst een kleur gebruikt hebt en dezelfde regel later een andere kleur geeft.
Klik om te vergroten...

Ik zit te denken aan een zoekfunctie die in het bestand geel2 kijkt of de regel al voorkomt.

Met vriendelijke groet,


Roncancio
 
In principe mag de regel best 2x voorkomen als het dan maar 2x een verschillende kleur is. (dat is wel makkelijk ook trouwens.)
Nu gebeurt het als er eerst een regel geel is en daarna geef je heem gee dat die gele regel er 3 of 4x in komt te staan.
 
Code: 
Dim sLoc As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range
Dim vFnd As Boolean
On Error Resume Next
bFnd = False
If IsError(Workbooks("geel2.xls")) Then
    MsgBox "Bestand is niet geopend.", vbExclamation, "File niet open."
Else
    If Not sLoc = "" Then
        If Range(sLoc).Interior.ColorIndex > 0 Then
            Set ZK = Workbooks("Geel2.xls").Worksheets(1).Range("A:A").Find(Range("A" & Target.Row), , xlValues, xlWhole)
            If Not ZK Is Nothing Then
                For Each cel In Workbooks("Geel2.xls").Worksheets(1).Range("A" & ZK.Row & ":IV" & ZK.Row)
                    If cel.Interior.Color = Range(sLoc).Interior.Color Then
                        bFnd = True
                    End If
                Next
            End If
            If ZK Is Nothing Or bFnd = False Then
                Range(sLoc).EntireRow.Copy Workbooks("geel2.xls").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        End If
    End If
    sLoc = Target.Address
End If

End Sub
Bovenstaande code is een aanpassing van de voorgaande.
In deze code wordt gekeken naar de A-kolom of de waarde al in het bestand Geel2 staat.
Zo ja, dan wordt ook gecontroleerd of de kleur in de rij ook op dezelfde rij staat.

Kan de waarde van de A-kolom niet gevonden worden, of de waarde staat er al maar met een andere kleur, dan wordt de rij toegevoegd.
In de overige gevallen niet.

Met vriendelijke groet,


Roncancio
 
Whoo, gaat niet helemaal goed.

Alles schiet in de stress, scherm staat een minuut lang te knipperen.(lijkt wel zoeken?)

trouwens staan de juiste gegevens om te zoeken in kolom D
 
Laatst bewerkt:
Hmm, opmerkelijk.
Volgens mij is dit zo beter.

Code: 
Dim sLoc As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range
Dim vFnd As Boolean
    Application.ScreenUpdating = False
    On Error Resume Next
    bFnd = False
    If IsError(Workbooks("geel2.xls")) Then
        MsgBox "Bestand is niet geopend.", vbExclamation, "File niet open."
    Else
        If Not sLoc = "" Then
            If Range(sLoc).Interior.ColorIndex > 0 Then
                Set ZK = Workbooks("Geel2.xls").Worksheets(1).Range("D:D").Find(Range("D" & Target.Row), , xlValues, xlWhole)
                If Not ZK Is Nothing Then
                    For Each cel In Workbooks("Geel2.xls").Worksheets(1).Range("D" & ZK.Row & ":IV" & ZK.Row)
                        If cel.Interior.Color = Range(sLoc).Interior.Color Then
                            bFnd = True
                        End If
                    Next
                End If
                If ZK Is Nothing Or bFnd = False Then
                    Range(sLoc).EntireRow.Copy Workbooks("geel2.xls").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            End If
        End If
        sLoc = Target.Address
    End If
    Application.ScreenUpdating = True

End Sub

Met vriendelijke groet,


Roncancio
 
Roncancio zei:
Hmm, opmerkelijk.
Volgens mij is dit zo beter.

Code: 
Dim sLoc As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range
Dim vFnd As Boolean
    Application.ScreenUpdating = False
    On Error Resume Next
    bFnd = False
    If IsError(Workbooks("geel2.xls")) Then
        MsgBox "Bestand is niet geopend.", vbExclamation, "File niet open."
    Else
        If Not sLoc = "" Then
            If Range(sLoc).Interior.ColorIndex > 0 Then
                Set ZK = Workbooks("Geel2.xls").Worksheets(1).Range("D:D").Find(Range("D" & Target.Row), , xlValues, xlWhole)
                If Not ZK Is Nothing Then
                    For Each cel In Workbooks("Geel2.xls").Worksheets(1).Range("D" & ZK.Row & ":IV" & ZK.Row)
                        If cel.Interior.Color = Range(sLoc).Interior.Color Then
                            bFnd = True
                        End If
                    Next
                End If
                If ZK Is Nothing Or bFnd = False Then
                    Range(sLoc).EntireRow.Copy Workbooks("geel2.xls").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            End If
        End If
        sLoc = Target.Address
    End If
    Application.ScreenUpdating = True

End Sub

Met vriendelijke groet,
Roncancio
Klik om te vergroten...

:thumb::thumb:Helemaal TOPPIE weer Roncancio :love::love:

nu nog een vraagje maar ik kan me indenken dat dat niet mogelijk is.


Het zou mooi zijn dat als er dus een regel word ingevoegd in het bestand dat de datum van de dag dat je dit doet erbij komt.
Omdat ik bang ben als ik een kolom ga toevoegen aan dit bestand dat alles dan in de soep loop dus misschien zou het dan een optie zijn om het als
opmerking (insert coment) erij te krijgen?

Maar nogmaal:
Je hebt me al fantastich geholpen en ben zeer blij met dit resultaat dus als het niet kan dan is dat (heel)jammer dan.
 
Dat is niet eens zo moeilijk.
Waar wil je de datum hebben?

Met vriendelijke groet,


Roncancio
 
Je blijft me verbazen:P:P
Maakt eigenlijk niet zoveel uit denk ik.
Wellicht in de eerste cel(kolomA) van de regel.
 
Code: 
Dim sLoc As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cel As Range
Dim vFnd As Boolean
    Application.ScreenUpdating = False
    On Error Resume Next
    bFnd = False
    If IsError(Workbooks("geel2.xls")) Then
        MsgBox "Bestand is niet geopend.", vbExclamation, "File niet open."
    Else
        If Not sLoc = "" Then
            If Range(sLoc).Interior.ColorIndex > 0 Then
                Set ZK = Workbooks("Geel2.xls").Worksheets(1).Range("D:D").Find(Range("D" & Target.Row), , xlValues, xlWhole)
                If Not ZK Is Nothing Then
                    For Each cel In Workbooks("Geel2.xls").Worksheets(1).Range("D" & ZK.Row & ":IV" & ZK.Row)
                        If cel.Interior.Color = Range(sLoc).Interior.Color Then
                            bFnd = True
                        End If
                    Next
                End If
                If ZK Is Nothing Or bFnd = False Then
                    Range(sLoc).EntireRow.Copy Workbooks("geel2.xls").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                    Workbooks("geel2.xls").Worksheets(1).Range("A" & Rows.Count).End(xlUp).Value = Date
                End If
            End If
        End If
        sLoc = Target.Address
    End If
    Application.ScreenUpdating = True

End Sub

Met vriendelijke groet,


Roncancio
 
:love: Zoals ik al zei: je bent een toppertje:love:

Thanks.:thumb:
 
Ha, daar ben ik toch nog weer een keertje.:p:p

Bestand geel2 bestaat uit 2 tabbladen.
tab 1 is het bestand dat dagelijks word geupdate en waarvan de regels (die een kleurtje krijgen) worden gekopieerd naar tab2.
Is het mogelijk dat als tab 1 weer eens is geupdate dat de regels die in tab2 al voorkomen in tab 1 ook dat kleurtje meekrijgen?
de criteria is dan weer komom D.
 
vrouw zei:
Ha, daar ben ik toch nog weer een keertje.:p:p

Bestand geel2 bestaat uit 2 tabbladen.
tab 1 is het bestand dat dagelijks word geupdate en waarvan de regels (die een kleurtje krijgen) worden gekopieerd naar tab2.
Is het mogelijk dat als tab 1 weer eens is geupdate dat de regels die in tab2 al voorkomen in tab 1 ook dat kleurtje meekrijgen?
de criteria is dan weer komom D.
Klik om te vergroten...

Staan er in de D-kolom unieke waardes?
Wat als er namelijk een waarde meerdere keren in de D-kolom voorkomt met verschillende kleuren?

Met vriendelijke groet,


Roncancio
 
Ja er staan in kolom D Staan unieke waardes :D
 
Code: 
Sub Controleren()
Dim lRij As Long
Dim lZRij As Long
    lRij = Blad2.Range("D" & Rows.Count).End(xlUp).Row
    For lZRij = 2 To lRij
        Set ZK = Blad1.Range("D:D").Find(Blad2.Range("D" & lZRij).Value, , xlValues, xlWhole)
        If Not ZK Is Nothing Then
            Blad2.Range(lZRij & ":" & lZRij).Copy
            Blad1.Range("A" & ZK.Row).EntireRow.PasteSpecial Paste:=xlPasteFormats
        End If
    Next
End Sub

Met vriendelijke groet,


Roncancio
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan