Doppelt Werte einfärben ....

Hallo zusammen,
ich habe folgendes Makro das mir doppelte Werte in Spalte A einfärbt. Ich bräuchte eine Änderung, bekomme das jedoch nicht hin...
A) Auf mehrere Spalten ausdehnen: Von Spalte B (!), jede 6. also H, N, T usw. (oder ist es jetzt jede 7.?), Buchstaben stimmen auf jeden Fall.
B) Wenn doppelte Einträge gefunden, färbe sowohl die Einträge als auch die 5 Zellen, die jeweils neben dem doppelten Werten stehen.
Bsp: B10: 1234 als doppelter Wert, Färbung: B10, C10, D10, F10, G10
Offset ist für letzteres wohl das falsche, wie ich feststellte...
Option Explicit

Public Sub Doppelte_Rot()
Dim lngZeile As Long
Dim lngZeilenSprung As Long
Dim strSuchwert As String
lngZeile = Cells(Rows.Count, 1).End(xlUp).Row
For lngZeilenSprung = lngZeile To 1 Step -1
strSuchwert = Cells(lngZeilenSprung, 1).Value
If Application.WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(lngZeile, 1)),  _
strSuchwert)  1 Then
Cells(lngZeilenSprung, 1).Interior.ColorIndex = 3
Cells(lngZeilenSprung, 1).Offset(, 3).Interior.ColorIndex = 3
End If
Next lngZeilenSprung
End Sub

Chris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Doppelte_Rot() Dim lngZeile As Long Dim lngZeilenSprung As Long Dim strSuchwert As String Dim lngSp As Long lngZeile = Cells(Rows.Count, 1).End(xlUp).Row For lngSp = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7 For lngZeilenSprung = 1 To lngZeile strSuchwert = Cells(lngZeilenSprung, lngSp).Value If strSuchwert > "" Then If Application.WorksheetFunction.CountIf( _ Range(Cells(1, lngSp), Cells(lngZeile, lngSp)), strSuchwert) 1 Then Cells(lngZeilenSprung, lngSp).Resize(, 5).Interior.ColorIndex = 3 End If End If Next lngZeilenSprung Next lngSp End Sub

Public Sub Doppelte_Rot() Dim lngLastZ As Long Dim lngZeile As Long Dim strSuchwert As String Dim lngSp As Long lngLastZ = Cells(Rows.Count, 1).End(xlUp).Row For lngSp = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 7 For lngZeile = 1 To lngLastZ strSuchwert = Cells(lngZeile, lngSp).Value If strSuchwert > "" Then If Application.WorksheetFunction.CountIf(Cells(1, lngSp). _ Resize(lngLastZ), strSuchwert) 1 Then Cells(lngZeile, lngSp).Resize(, 6).Interior.ColorIndex = 3 End If End If Next lngZeile Next lngSp End Sub

Sub Doppelte_Rot() Dim lngZeile As Long Dim lngZeilenSprung As Long Dim strSuchwert As String Dim lngSp As Long lngZeile = Cells(Rows.Count, 1).End(xlUp).Row For lngSp = 2 To Cells(1, Columns.Count).End(xlToLeft).Column Step 6 For lngZeilenSprung = 1 To lngZeile strSuchwert = Cells(lngZeilenSprung, lngSp).Value If strSuchwert > "" Then If Application.WorksheetFunction.CountIf( _ Range(Cells(1, lngSp), Cells(lngZeile, lngSp)), strSuchwert) 1 Then Cells(lngZeilenSprung, lngSp).Resize(, 6).Interior.ColorIndex = 3 End If End If Next lngZeilenSprung Next lngSp End Sub

Option Explicit Public Sub Doppelte_Rot3() Dim lngLastZ As Long Dim lngZeile As Long Dim strSuchwert As String Dim lngSp As Long For lngSp = 2 To LetzteSpalteTab() Step 6 lngLastZ = Cells(Rows.Count, lngSp).End(xlUp).Row If lngLastZ > 16 Then For lngZeile = 16 To lngLastZ strSuchwert = Cells(lngZeile, lngSp).Value If strSuchwert > "" Then If Application.WorksheetFunction.CountIf(Cells(16, lngSp). _ Resize(lngLastZ), strSuchwert) 1 Then Cells(lngZeile, lngSp).Resize(, 6).Interior.ColorIndex = 3 End If End If Next lngZeile End If Next lngSp End Sub Function LetzteSpalteTab(Optional bChar As Boolean = False) Dim rng As Range Set rng = Cells.Find("*", Cells(1, 1), xlValues, , xlByColumns, xlPrevious) If rng Is Nothing Then If bChar Then LetzteSpalteTab = "" Else LetzteSpalteTab = 0 Else If bChar Then LetzteSpalteTab = SpalteNum2Txt(rng.Column) Else LetzteSpalteTab = rng.Column End If End If End Function Function SpalteNum2Txt(iNr As Long) As String SpalteNum2Txt = Replace(Cells(1, iNr).Address(0, 0), "1", "") End Function

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread