Zeilengruppen Formatieren VBA

Sub Zusammenhaengende_Datensaetze_hervorheben() Dim lngZeile As Long, i As Long, x As Long 'Dim strReferenzNr As String 'Dim strReferenzNrSpalte As String Dim strDatumsSpalte As String Dim lngDatumWert As Long strDatumsSpalte = "C" i = 2 lngZeile = Range(strDatumsSpalte & Rows.Count).End(xlUp).Row lngDatumWert = Range(strDatumsSpalte & i).Value x = 2 For i = 2 To lngZeile If CLng(Range(strDatumsSpalte & i).Value) CLng(lngDatumWert) Then x = x + 1 lngDatumWert = CLng(Range(strDatumsSpalte & i).Value) End If If x Mod 2 0 Then Range("A" & i & ":X" & i).Interior.Color = 14348258 Else Range("A" & i & ":X" & i).Interior.Color = 13431551 End If Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Das ist ein Folge Thread zu dem hier https://www.herber.de/forum/archiv/1908to1912/1908495_Zeilengruppen_2xBedingte_Formatieren.html
wo es zuerst mit Bedingter Formatierung umgesetzt werden sollte. Da hat mir Onur auch schon sehr geholfen. Nur letzten Endes musste es aufgrund der Datenbereinigung doch per VBA sein.
Lieber Onur, es funktionier bestens, vielen vielen dank für die Hilfe von dem Code werde ich lange zeit was haben. :)))))))))))))))
Es ist ein kleiner Fehler drin ein mal "next z" zu viel. In der Mitte des Codes. Ich kommentier es mal aus und Poste den Code aus Onurs Datei hier:


Private Sub CommandButton1_Click()
Dim z, s, spdt, sprf, lz, ls, dif, dark As Byte, c As Byte, co(1) As Long
dif = 657930
co(0) = 14348258 'gr
co(1) = 13431551 'ge
'    Debug.Print co1 - co3
'    Debug.Print co2 - co4
'    Debug.Print RGB(10, 10, 10)
lz = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ls = ActiveSheet.Cells(1, 256).End(xlToLeft).Column
For s = 1 To ls
If Cells(1, s) = "Datum" Then spdt = s
If Left(Cells(1, s), 8) = "Referenz" Then sprf = s
Next s
Range(Cells(1, 1), Cells(lz, ls)).Interior.Color = RGB(255, 255, 255)
''Next z
Range(Cells(2, 1), Cells(2, ls)).Interior.Color = co(c)
For z = 3 To lz
If Int(Cells(z, spdt))  Int(Cells(z - 1, spdt)) Then
c = 1 - c
Else
If bereinigt(Cells(z, sprf))  bereinigt(Cells(z - 1, sprf)) Then dif = 657930 - dif
End If
Range(Cells(z, 1), Cells(z, ls)).Interior.Color = co(c) - dif
Next z
End Sub
Public Function bereinigt(txt As String)
txt = Replace(txt, "#", "")
txt = Replace(txt, "*", "")
txt = Replace(txt, " ", "")
bereinigt = txt
End Function

Grüße
Mathias
-----------------------------------------------------------Thread Ende------------------------------------------------

Sub t() Dim rngBereich As Range, rngZeile As Range Dim b1 As Boolean, b2 As Boolean Dim intDat As Integer, intRef As Integer On Error Resume Next With ActiveSheet intDat = Application.Match("Datum", .Rows(1), 0) intRef = Application.Match("Referenz_Nr", .Rows(1), 0) Set rngBereich = .Range("A2:X" & .Cells(.Rows.Count, 1).End(xlUp).Row) rngBereich.Interior.Color = xlNone For Each rngZeile In rngBereich.Rows If .Cells(rngZeile.Row, intDat).Text .Cells(rngZeile.Row - 1, intDat).Text Then b1 = Not b1 b2 = False ElseIf Left(Replace(.Cells(rngZeile.Row, intRef), " ", ""), 16) Left(Replace(.Cells(rngZeile.Row - 1, intRef), " ", ""), 16) Then b2 = Not b2 End If If b1 = True And b2 = False Then rngZeile.Interior.ColorIndex = 35 ElseIf b1 = True And b2 = True Then rngZeile.Interior.ColorIndex = 4 ElseIf b1 = False And b2 = False Then rngZeile.Interior.ColorIndex = 19 Else rngZeile.Interior.ColorIndex = 36 End If Next rngZeile End With End Sub

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilengruppen Formatieren VBA

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread