Ændre farve alt efter hvad der står i feltet med en macro

Kan du ikke bruge betinget formatering:

Formater > Betinget formatering

Der kan du indsætte op til 3 betingelser i hver celle.

Vil du selv bestemmer farven?, f.eks ved at du selv giver navnet en farve først det optræder

Eller har du farverne et andet sted, f.eks en liste

Hvert navn skal have en bestemt farve, og den samme heletiden. Nej jeg kan ikke bruge betinget formatering da der kun er 3 betingelser. Hvis der står Lasse skal rækken altid være gul osv..

Denne kode sætter noget af farverne, men jeg mangler stadigvæk og få at vide hvor farverne skal komme fra?

Private Sub CommandButton1_Click()
 
  Const Kolonne As String = "A"
  Const StartRække As Integer = 1
  Const Regneark As String = "Sheet1"
  Dim SlutRække As Integer
 
  SlutRække = Range(Kolonne & StartRække) _
  .CurrentRegion.Rows.Count + StartRække - 1

For Each r In Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)
    If r.Interior.ColorIndex = xlNone Then
        Select Case r.Value
        Case "Lasse"
            r.Interior.ColorIndex = 3
            r.Interior.Pattern = xlSolid
        Case "Kurt"
            r.Interior.ColorIndex = 4
            r.Interior.Pattern = xlSolid
        End Select
    End If
Next r


End Sub

Denne kode, sætten farven efter hvilke farve navnet havde forrige gang


Private Sub CommandButton1_Click()
 
  Const Kolonne As String = "A"
  Const StartRække As Integer = 1
  Const Regneark As String = "Sheet1"
  Const farve As Integer = 1
  Const navn As Integer = 0
  Dim SlutRække As Integer
  Dim tabel(1000, 2) As Variant
 
SlutRække = Range(Kolonne & StartRække).CurrentRegion.Rows.Count + StartRække - 1
navnnr = 0
For Each r In Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)
    If r.Interior.ColorIndex <> xlNone Then
        tabel(navnnr, farve) = r.Interior.ColorIndex
        tabel(navnnr, navn) = r
        navnnr = navnnr + 1
    End If
Next r

For Each r In Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)
    If r.Interior.ColorIndex = xlNone Then
        For i = 0 To navnnr
            If UCase(r.Value) = UCase(tabel(i, navn)) Then
                For t = 0 To 2
                r.Offset(0, t).Interior.Pattern = xlSolid
                r.Offset(0, t).Interior.ColorIndex = tabel(i, farve)
                Next t
            End If
        Next i
    End If
Next r
End Sub

Det virker fint, men er meget langsomt, jeg har 11 celler der skal farves. Kan man ikke farve en hel række adgangen? F.eks. fra A1 til K1 på engang?

Jooo, det kan man godt. Jeg kúnne bare ikke lige få det til at virke igår, så det sprang jeg over.

Prøv om dette er hurtigere

Private Sub CommandButton1_Click()
 
  Const Kolonne As String = "A"
  Const KolonneSlut As String = "K"
  Const StartRække As Integer = 1
  Const Regneark As String = "Sheet1"
  Const farve As Integer = 1
  Const navn As Integer = 0
  Dim SlutRække As Integer
  Dim tabel(1000, 2) As Variant
 
SlutRække = Range(Kolonne & StartRække).CurrentRegion.Rows.Count + StartRække - 1
Set omrade = Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)

Application.ScreenUpdating = False
navnnr = 0
For Each r In omrade
    If r.Interior.ColorIndex <> xlNone Then
        tabel(navnnr, farve) = r.Interior.ColorIndex
        tabel(navnnr, navn) = r
        navnnr = navnnr + 1
    End If
Next r

For Each r In omrade
    If r.Interior.ColorIndex = xlNone Then
        For i = 0 To navnnr
            If UCase(r.Value) = UCase(tabel(i, navn)) Then
                Range(Kolonne & r.Row & ":" & KolonneSlut & r.Row).Interior.ColorIndex = tabel(i, farve)
            End If
        Next i
    End If
Next r
Application.ScreenUpdating = True

End Sub

Denne kode farver også dem der har en farve i 1.kolonne.

Private Sub CommandButton1_Click()
 
  Const Kolonne As String = "A"
  Const KolonneSlut As String = "K"
  Const StartRække As Integer = 1
  Const Regneark As String = "Sheet1"
  Const farve As Integer = 1
  Const navn As Integer = 0
  Dim SlutRække As Integer
  Dim tabel(1000, 2) As Variant
 
SlutRække = Range(Kolonne & StartRække).CurrentRegion.Rows.Count + StartRække - 1
Set omrade = Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)

Application.ScreenUpdating = False
navnnr = 0
For Each r In omrade
    If r.Interior.ColorIndex <> xlNone Then
        tabel(navnnr, farve) = r.Interior.ColorIndex
        tabel(navnnr, navn) = r
        navnnr = navnnr + 1
    End If
Next r

For Each r In omrade
        For i = 0 To navnnr
            If UCase(r.Value) = UCase(tabel(i, navn)) Then
                Range(Kolonne & r.Row & ":" & KolonneSlut & r.Row).Interior.ColorIndex = tabel(i, farve)
            End If
        Next i

Next r
Application.ScreenUpdating = True

End Sub

Det virker bare rigtigt fint, men lige et sidste men er det muligt at den tager efter den første farve og ikke den sidste når macroen køres??

Prøv dette

Private Sub CommandButton1_Click()
 
  Const Kolonne As String = "A"
  Const KolonneSlut As String = "K"
  Const StartRække As Integer = 1
  Const Regneark As String = "Sheet1"
  Const farve As Integer = 1
  Const navn As Integer = 0
  Dim SlutRække As Integer
  Dim tabel(1000, 2) As Variant
 
SlutRække = Range(Kolonne & StartRække).CurrentRegion.Rows.Count + StartRække - 1
Set omrade = Range(Kolonne & StartRække & ":" & Kolonne & SlutRække)

Application.ScreenUpdating = False
navnnr = 0
For Each r In omrade
    If r.Interior.ColorIndex <> xlNone Then
        tabel(navnnr, farve) = r.Interior.ColorIndex
        tabel(navnnr, navn) = r
        navnnr = navnnr + 1
    End If
Next r

For Each r In omrade
        For i = navnnr To 0 Step -1
            If UCase(r.Value) = UCase(tabel(i, navn)) Then
                Range(Kolonne & r.Row & ":" & KolonneSlut & r.Row).Interior.ColorIndex = tabel(i, farve)
            End If
        Next i
Next r
Application.ScreenUpdating = True

End Sub

Husk at accepter

Lukketid ??, Det er altid rart at få sine point, når man nu har brugt sin fritid på at hjælpe andre

Enig!!

Undskyld jeg har været bortrejst i et stykke tid...