Farve enkelte celler i excel via VBA & kan man have to forskellige farver i én linje?

Prøv:

Tak.

Hvis jeg vil farve de celler sorte, men jeg vil farve resten fx røde. Hvordan skal jeg så gøre?

Prøv:

Prøv evt.:

Naturligvis, bortset fra at når jeg sætter koden til, så farver den cellerne under? Og ikke fra A til F, men underlader celle D.



If Cells(i, 1) = "Proces" Then

        Rng = "E" & i & ":" & "G" & i & "," & "J" & i & ":" & "O" & i
        Range(Rng).Interior.Color = RGB(0, 0, 0)  'Sort
   

Else
      Rng = "A" & i & ":" & "F" & i
        Range(Rng).Interior.Color = RGB(168, 0, 0)  'Rød
        End If

Det gik helt galt, den farvede hele koloner :-P

Du får lige hele koden, måske du kan gennemskue fejlen:

Sub Hovedark()

Dim strColor As String
Dim FontColor As String

Set rng1 = Range("E" & i & ":" & "G" & i)
Set rng2 = Range("J" & i & ":" & "O" & i)
Set MultiRanges = Union(rng1, rng2)

FontColor = vbBlack

i = 6 'start row number


For Each c In ActiveSheet.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

    If Cells(i, 1) = "Proces" Then

        Rng = "G" & i & "," & "H" & i
        Range(Rng).Interior.Color = RGB(0, 0, 0)  'Sort
        Range(Rng).Font.Color = FontColor
        Cells(i, 4).Font.Italic = True
        Cells(i, 5).Font.Italic = True
        Cells(i, 6).Font.Italic = True
        Cells(i, 3) = Format(Date, "d-mmm-yy")
        Cells(i, 4) = "Hvad skete der?"
        Cells(i, 5) = "Hvad følte jeg?"
        Cells(i, 6) = "Hvad lærte jeg?"
       
        Else
      Rng = "A" & i & ":" & "F" & i
        Range(Rng).Interior.Color = RGB(168, 0, 0)  'Rød
        End If
       
       
        If Cells(i, 1) = "Metakognitiv" Then

        Rng = "G" & i & ":" & "H" & i
        Range(Rng).Interior.Color = RGB(216, 228, 188) 'Grøn
        Range(Rng).Font.Color = vbBlack
        End If
       
        If Cells(i, 1) = "Syntese" Then

       
        Rng = "A" & i & ":" & "D" & i
        Range(Rng).Interior.Color = RGB(204, 192, 218) 'Orange
        Range(Rng).Font.Color = vbBlack
        End If
       
       
     
       
        If Cells(i, 3) = "Refleksionslog" Then

        Rng = "A" & i & ":" & "H" & i
        Range(Rng).Interior.Color = RGB(204, 192, 218) 'Orange
        Range(Rng).Font.Color = vbBlack
        End If
       
     
     
       
        If Cells(i, 3) = "" Then
        Cells(i, 4).Interior.ColorIndex = 0 'Ingen farve
        End If
     
   
       

    i = i + 1
  Next c


End Sub

Set rng1 = Range("E" & i & ":" & "G" & i) 'E:G
Set rng2 = Range("J" & i & ":" & "O" & i) 'J:O
Set rng3 = Range("A" & i & ":" & "F" & i) 'A:F

Set MultiRanges = Union(rng1, rng2)

If Cells(i, 1) = "Proces" Then
    MultiRanges.Interior.Color = 1  'E:G og J:O =Sort
Else
    rng3.Interior.Color = 3  'A:F =Rød
End If

Nope, det løser det heller ikke.
Jeg må arbejde videre med else :-) Men tak for din hjælp:-)

Den farver næsten hele arket :-)

Kikke på det

Jeg behøver slet ikke en else-sætning:

If Cells(i, 1) = "Proces" Then

        Rng = "G" & i & "," & "H" & i
        Range(Rng).Interior.Color = RGB(0, 0, 0)  'Sort
        Range(Rng).Font.Color = FontColor
        Cells(i, 4).Font.Italic = True
        Cells(i, 5).Font.Italic = True
        Cells(i, 6).Font.Italic = True
        Cells(i, 3) = Format(Date, "d-mmm-yy")
        Cells(i, 4) = "Hvad skete der?"
        Cells(i, 5) = "Hvad følte jeg?"
        Cells(i, 6) = "Hvad lærte jeg?"
        Rng = "A" & i & ":" & "F" & i
        Range(Rng).Interior.Color = RGB(80, 0, 0) 'Orange
        End If


Jeg kan bare indsætte en anden Range igen, Men du skal have så meget tak for hjælpen, det var så fedt, du gad kigge på det :-) Du får Point for dine anstrengelser :-)

Sub Hovedark()

Dim strColor As String
Dim FontColor As String

FontColor = vbBlack

i = 6 'start row number

For Each c In ActiveSheet.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

        If Cells(i, 1) = "Proces" Then
            Rng = "G" & i & "," & "H" & i 'G og H
            Range(Rng).Interior.Color = RGB(0, 0, 0)  'Sort
            Range(Rng).Font.Color = FontColor
            Cells(i, 4).Font.Italic = True
            Cells(i, 5).Font.Italic = True
            Cells(i, 6).Font.Italic = True
            Cells(i, 3) = Format(Date, "d-mmm-yy")
            Cells(i, 4) = "Hvad skete der?"
            Cells(i, 5) = "Hvad følte jeg?"
            Cells(i, 6) = "Hvad lærte jeg?"
        Else
            Rng = "A" & i & ":" & "F" & i 'A:F
            Range(Rng).Interior.Color = RGB(168, 0, 0)  'Rød
            End If
       
        If Cells(i, 1) = "Metakognitiv" Then
            Rng = "G" & i & ":" & "H" & i 'G:H
            Range(Rng).Interior.Color = RGB(216, 228, 188) 'Grøn
            Range(Rng).Font.Color = vbBlack
        End If
       
        If Cells(i, 1) = "Syntese" Then
            Rng = "A" & i & ":" & "D" & i 'A:D
            Range(Rng).Interior.Color = RGB(204, 192, 218) 'Orange
            Range(Rng).Font.Color = vbBlack
        End If
       
        If Cells(i, 3) = "Refleksionslog" Then
            Rng = "A" & i & ":" & "H" & i 'A:H
            Range(Rng).Interior.Color = RGB(204, 192, 218) 'Orange
            Range(Rng).Font.Color = vbBlack
        End If
       
        If Cells(i, 3) = "" Then
            Cells(i, 4).Interior.ColorIndex = 0 'Ingen farve
        End If

    i = i + 1
  Next c
End Sub

Kan ikke finde fejl, ud over at rækkefølgen ændre på farver der er sat.