Rij auto nummering en kleuring

[messagedj]

Ik probeer in excel een overzicht te maken van mijn financiën.

soms verkoop ik aan een klant 1 product en soms meerdere. Elk product wil ik op een eigen regel hebben, Daardoor heeft een klant in mijn overzicht soms 3 regels, soms 2 en soms 1.

ik wil graag een automatische nummering zodra ik een nieuwe klant invoer (kolom A) en ik wil graag dat de rij verandert van kleur. Er zijn twee kleuren, Wit en Grijs. Bij een nieuwe klant start een nieuwe kleur.

Wie kan me helpen??


Bekijk bijlage voorbeeld.xlsx

 

[Cobbe]

Zet deze in A4 en trek naar beneden:

=ALS(B4="";"";MAX($A$3:$A3)+1)

 

[messagedj]

thnx... die werkt zeker voor het optellen !

en de kleuren ? kun je me daar ook mee helpen?

 

[Cobbe]

Misschien met deze code achter je werkblad te hangen:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then
For Each cl In Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row)
  If cl = "" Then Rows(cl.Row).Interior.ColorIndex = kleur2
   kleur1 = Rows(cl.Row - 1).Interior.ColorIndex
    kleur2 = Rows(cl.Row).Interior.ColorIndex
 If cl <> "" And cl > cl.Offset(-1) Then
   If kleur1 = kleur2 Then kleur2 = 15
    Rows(cl.Row).Interior.ColorIndex = kleur2
 End If
Next
End If
End Sub

 

[messagedj]

hey Cobbe,

thnx man, die werkt. in mijn voorbeeld gebruik ik Kolom B als leidend, maar wat als dat kolom C wordt?... want ik heb wat B's aangepast maar dan geeft hij een error. Ik snap die code namelijk niet goed...

bijzonder dank voor de supersnelle en goede hulp hier!

 

[Cobbe]

Heb de code aangepast voor kolom C en tevens wat summiere uitleg toegevoegd.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cl As Range
' De code enkel laten lopen als er binnen kolom C bewogen wordt
If Not Intersect(Target, Range("C4:C" & Range("C" & Rows.Count).End(xlUp).Row)) Is Nothing Then
' haal de beveiliging er even af
 ActiveSheet.Unprotect Password:=1234
' Loop de rijen in kolom C af zover als er inhoud staat
For Each cl In Range("C4:C" & Range("C" & Rows.Count).End(xlUp).Row)
' de al dan niet gekleurde rij wordt ontkleurd
 Range(Cells(cl.Row, 1), Cells(cl.Row, 6)).Interior.ColorIndex = xlNone
' Als de cel in kolom C leeg = wordt de variabele 'kleur 2' bepaald
  If cl = "" Then Range(Cells(cl.Row, 1), Cells(cl.Row, 6)).Interior.ColorIndex = kleur2
' Kleur 1 en kleur 2 worden opgehaald
   kleur1 = Range(Cells(cl.Row - 1, 1), Cells(cl.Row - 1, 6)).Interior.ColorIndex
    kleur2 = Range(Cells(cl.Row, 1), Cells(cl.Row, 6)).Interior.ColorIndex
' Als cel niet leeg is en de celinhoud is groter dan de cel erboven
 If cl <> "" And cl > cl.Offset(-1) Then
' dan als cel = cel-1 dan kleur 2 wordt 'grijs'
   If kleur1 = kleur2 Then kleur2 = 15
' de hele rij wordt gekleurd
    Range(Cells(cl.Row, 1), Cells(cl.Row, 6)).Interior.ColorIndex = kleur2
 End If
Next
' zet de beveiliging er terug op
 ActiveSheet.Protect Password:=1234
End If
End Sub

 

[messagedj]

ik krijg een fout 1004

in regel
Rows(cl.Row).Interior.ColorIndex = xlNone


nogmaals dank voor de hulp !

 

[Cobbe]

Heb je je werkblad beveiligd?

 

[messagedj]

Ahhh dat moet het zijn.. Alleen de kolommen C tm J zijn editable, de rest is inderdaad beveiligd.

jij weet daar vast wel een uitbreidingscode voor, of is VB scrips nooit te draaien op beveiligde tabbladen, zelfs als de VB code uitsluitend op niet beveiligde cellen toegepast is?

 

[Cobbe]

Heb de vorige code aangepast met een beveiliging op je werkblad met wachtwoord 1234

Heb je een ander paswoord dien je dit natuurlijk te wijzigen in de code op de 2 plaatsen.

 

[messagedj]

laatste vraag hoor, want je hebt me al meer dan goed geholpen. Kan ik een bereik opgeven voor het kleuren van de cellen? hij kleurt nu de hele rij,

moet iets zijn als

Range("C" & Target.Row, "J" & Target.Row)

maar geen idee waar ik die dan moet plaatsen

 

[Cobbe]

Heb de vorige code weer aangepast, nu voor 6 kolommen.
Eventueel aanpassen naar meer/minder kolommen zal wel lukken zeker?

 

[messagedj]

ik ga je voordragen voor de nobelprijs van de excel.

super bedankt !