AW: meine Lösung
08.11.2018 11:56:09
Peter
Hallo Werner,
Option Explicit
Sub doppelte_Zellen_SpalteCundD_entfernen()
Dim lngZeile As Long 'benötigt für Einfärben der doppelten Zellen
Application.ScreenUpdating = False
For lngZeile = 1 To Cells(65536, 4).End(xlUp).Row 'benötigt für Einfärben der doppelten _
Zellen
'Anfang doppelte Zellen einfärben
If Cells(lngZeile, 4) = Cells(lngZeile + 1, 4) And Cells(lngZeile, 3) = Cells(lngZeile + _
1, 3) Then
'Einfärben SpalteD doppelte
With Range(Cells(lngZeile, 4), Cells(lngZeile + 1, 4))
.Font.ColorIndex = 3
End With
'Einfärben SpalteC doppelte
With Range(Cells(lngZeile, 3), Cells(lngZeile + 1, 3))
.Font.ColorIndex = 3
End With
End If
Next
'Ende doppelte Zellen einfärben
'löscht erste gefärbte Zelle Spalte C
Call SpalteC_wähltErstegefärbteZellevonunten_löschen2
'löscht erste gefärbte Zelle Spalte D
Call SpalteD_wähltErstegefärbteZellevonunten_löschen2
'ändert Schriftfarbe von rot auf scharz in Spalten C und D
Call Schriftfarbe_ändern_schwarz2
Application.ScreenUpdating = True
End Sub
'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub SpalteC_wähltErstegefärbteZellevonunten_löschen2()
Dim a As Long 'benötigt für erste gefärbte Zelle von _
unten löschen Spalte C
For a = Range("c65536").End(xlUp).Row To 1 Step -1 'benötigt für erste gefärbte Zelle von _
unten löschen Spalte C
'Anfang für erste gefärbte Zelle von unten löschen Spalte C
If Cells(a, 3).Font.ColorIndex = 3 Then
'löscht die erste gefärbte Zelle von unten Spalte C
Cells(a, 3).Delete Shift:=xlUp
Exit Sub
End If
Next a
'Ende für erste gefärbte Zelle von unten löschen Spalte C
End Sub
'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub SpalteD_wähltErstegefärbteZellevonunten_löschen2()
Dim a As Long 'benötigt für erste gefärbte Zelle von _
unten löschen Spalte C
For a = Range("D65536").End(xlUp).Row To 1 Step -1 'benötigt für erste gefärbte Zelle von _
unten löschen Spalte C
'Anfang für erste gefärbte Zelle von unten löschen Spalte D
If Cells(a, 4).Font.ColorIndex = 3 Then
'löscht die erste gefärbte Zelle von unten Spalte D
Cells(a, 4).Delete Shift:=xlUp
Exit Sub
End If
Next a
'Ende für erste gefärbte Zelle von unten löschen Spalte D
End Sub
'ausgeführt in Makro "doppelte_Zellen_SpalteCundD_entfernen"
Sub Schriftfarbe_ändern_schwarz2()
'Anfang Schriftfarbe in scharz ändern
'SpalteC
With Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp)).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'SpalteD
With Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp)).Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'Ende Schriftfarbe in scharz ändern
End Sub
Wünsche noch einen schönen Tag.
Gruss
Peter