Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Schleife Farbhintergrund setzen

VBA Schleife Farbhintergrund setzen
Dieter(Drummer)
Hi VBA Spezislisten,
suche ein VBA Lösung: Der Bereich ist A4 bis AH34! Ab der aktiven Zelle sollen 3 Zellen BLAU, die nächsten 3 ROT und die nächsten 3 GRÜN Hintergrund gefärbt werden. Dann wieder mit ROT usw. beginnen. Dies soll sich max. bis Zeile 34 der aktiven Spalte wiederholen.
Der Beginn ist immer die aktivierte Zelle und gilt nur für die aktive Spalte.
Danke für evtl. Hilfe.
Gruß
Dieter(Drummer)

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: VBA Schleife Farbhintergrund setzen
27.04.2011 12:53:49
Armin
Hallo,
mit diesem Code sollte das funktionieren:
Sub farbschleife()
z = ActiveCell.Row
s = ActiveCell.Column
f = 0
farbe = 5
For a = 1 To 34
Cells(z, s).Interior.ColorIndex = farbe
z = z + 1
f = f + 1
If f = 3 Then
If farbe = 5 Then
farbe = 3
ElseIf farbe = 3 Then
farbe = 10
ElseIf farbe = 10 Then
farbe = 5
End If
f = 0
End If
Next a
End Sub
Viele Grüße
Armin
AW: Max. Zeile 34 ...
27.04.2011 13:02:28
Dieter(Drummer)
Hi Armin,
Danke für schnellle Hilfe. Es funktioniert schon prima. Es darf aber nur max. bis Zeile 34 gefärbt werden. Die Farbhinterlegung muss also bei Zeile 34 enden!
Kannst Du das noch anpassen?
Gruß
Dieter(Drummer)
Anzeige
AW: Max. Zeile 34 ...
27.04.2011 13:20:30
Armin
Hallo Dieter,
hier der angepasste Code, jetzt nur bis Zeile 34
Sub farbschleife()
z = ActiveCell.Row
s = ActiveCell.Column
f = 0
farbe = 5
For a = 1 To 34
Cells(z, s).Interior.ColorIndex = farbe
z = z + 1
f = f + 1
If f = 3 Then
If farbe = 5 Then
farbe = 3
ElseIf farbe = 3 Then
farbe = 10
ElseIf farbe = 10 Then
farbe = 5
End If
f = 0
End If
If z = 35 Then Exit Sub
Next a
End Sub
Viele Grüße
Armin
AW: VBA Schleife Farbhintergrund setzen
27.04.2011 13:02:41
Tino
Hallo,
meinst Du so?
Sub Farben()
Dim rngBereich As Range, lngRow As Long
Dim lngFarbe As Long, lngOffset As Long

With ActiveCell(1, 1)
    If Not Intersect(.Cells(1, 1), Range("A4:AH34")) Is Nothing Then
        Range("A4:AH34").Interior.ColorIndex = xlColorIndexNone
        Set rngBereich = Range(Cells(.Cells(1, 1).Row, 1), "AH34")
        For lngRow = 1 To rngBereich.Rows.Count Step 3
            Select Case lngRow Mod 9
                Case 1: lngFarbe = 12611584 'blau 
                Case 4: lngFarbe = 255 'rot 
                Case 7: lngFarbe = 5287936 'grün 
            End Select
            lngOffset = Application.WorksheetFunction.Min(35 - rngBereich.Rows(lngRow).Row, 3)
            rngBereich.Rows(lngRow).Resize(lngOffset).Interior.Color = lngFarbe
        Next
    End If
End With
End Sub
Gruß Tino
Anzeige
AW: Farbe nur BIS Zeile 34 ...
27.04.2011 13:18:13
Dieter(Drummer)
Hi Tino,
Danke für deinen Vorschlag. Es wird hier aber der GANZE Bereich gefärbt. Es darf aber NUR ab AKTIVER ZELLE - die ich gerade aktiviert habe - gefärbt werden UND darf nur innerhalb dieser Spalte bis max. Zeile 34 gehen.
Geht das noch?
Gruß
Dieter(Drummer)
jetzt habe ich es verstanden...
27.04.2011 13:41:49
Tino
Hallo,
Sub Farben()
Dim rngBereich As Range, lngRow As Long
Dim lngFarbe As Long, lngOffset As Long

With ActiveCell
    If Not Intersect(.Cells, Range("A4:AH34")) Is Nothing Then
        Range("A4:AH34").Interior.ColorIndex = xlColorIndexNone
        Set rngBereich = Range(Cells(.Row, .Column), Cells(34, .Column))
        For lngRow = 1 To rngBereich.Rows.Count Step 3
            Select Case lngRow Mod 9
                Case 1: lngFarbe = 12611584 'blau 
                Case 4: lngFarbe = 255 'rot 
                Case 7: lngFarbe = 5287936 'grün 
            End Select
            lngOffset = Application.WorksheetFunction.Min(35 - rngBereich.Rows(lngRow).Row, 3)
            rngBereich.Rows(lngRow).Resize(lngOffset).Interior.Color = lngFarbe
        Next
    End If
End With
End Sub
Gruß Tino
Anzeige
ActiveCell(1, 1)
27.04.2011 13:32:16
Rudi
Hallo Tino,
(1, 1) ist überflüssig, da ActiveCell immer nur eine Zelle ist. Im Gegensatz zu Selection.
Gruß
Rudi
stimmt :-) oT.
27.04.2011 13:35:54
Tino
AW: VBA Schleife Farbhintergrund setzen
27.04.2011 13:27:02
Rudi
Hallo,
noch ein Vorschlag
Sub tttt()
Dim rng As Range, i As Long
If Not Intersect(ActiveCell, Range("A4:AH34")) Is Nothing Then
Set rng = Range(ActiveCell, Cells(34, ActiveCell.Column))
For i = 1 To rng.Rows.Count
Select Case i Mod 9
Case 1 To 3: rng(i).Interior.Color = RGB(0, 0, 255)
Case 4 To 6: rng(i).Interior.Color = RGB(255, 0, 0)
Case Else: rng(i).Interior.Color = RGB(0, 255, 0)
End Select
Next
End If
End Sub

Gruß
Rudi
Anzeige
AW: Dank an ALLE ... Rudis Lösung ...
27.04.2011 13:32:20
Dieter(Drummer)
Hi Rudi,
Danke für schnelle und excellente Lösung. Funktioniert einwandfrei!
Gruß
Dieter(Drummer)
AW: Frage an @Rudi Maintaire
27.04.2011 16:27:07
Dieter(Drummer)
Hi Rudi,
Danke nochmal für deine heutige Hilfe!
Kannst Du mir dein Makro auch so anpassen, dass es die Farben innerhalb der ZEILE legt und nicht innerhalb der Spalte? Der Bereich wäre hier C3:AM26. In Spalte AM ist jeweils Schluss der Farbsetzung je ZEILE.
Hier nochmal dein vorheriges Makro:
Sub ttt() 'von Rudi Maintaire am 27.04.2011 13:27:02
Dim rng As Range, i As Long
If Not Intersect(ActiveCell, Range("A4:AH34")) Is Nothing Then
Set rng = Range(ActiveCell, Cells(34, ActiveCell.Column))
For i = 1 To rng.Rows.Count
Select Case i Mod 9
Case 1 To 3: rng(i).Interior.Color = RGB(0, 0, 255)
Case 4 To 6: rng(i).Interior.Color = RGB(255, 0, 0)
Case Else: rng(i).Interior.Color = RGB(0, 255, 0)
End Select
Next
End If
End Sub
Eine Lösung wäre prima.
Gruß
Dieter(Drummer
Anzeige
AW: Frage an @Rudi Maintaire
27.04.2011 17:05:34
Rudi
Hallo,
is doch das Gleiche in gedreht.
Sub tttx() 'von Rudi Maintaire am 27.04.2011
Dim rng As Range, i As Long
If Not Intersect(ActiveCell, Range("C3:AM26")) Is Nothing Then
Set rng = Range(ActiveCell, Cells(ActiveCell.Row, 39))
For i = 1 To rng.Columns.Count
Select Case i Mod 9
Case 1 To 3: rng(i).Interior.Color = RGB(0, 0, 255)
Case 4 To 6: rng(i).Interior.Color = RGB(255, 0, 0)
Case Else: rng(i).Interior.Color = RGB(0, 255, 0)
End Select
Next
End If
End Sub

Gruß
Rudi
AW: Danke Rudi, Klappt prima!
27.04.2011 17:13:19
Dieter(Drummer)
Gruß und Danke ...
Dieter(Drummer)

313 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige