AW: Farblich markieren
16.05.2012 15:30:37
JoWE
Hallo Gisi,
ich hätte hier einen weiteren Code; genauso einfügen wie beim ersten Mal:
Das Makro habe ich irgendwann mal von irgendwoher (ich glaube supportnet...) gefunden,
das könnte Deiner Anforderung am nächsten kommen.
Sub MurderMo_Sort()
With Application
.EnableEvents = False 'Events abschalten
'.ScreenUpdating = False 'Bildschirmaktualisierung abschalten
.Calculation = xlCalculationManual 'Berechnungsmodus auf Manuell
End With
'wenn Fehler gehe zum Ende
On Error GoTo ErrEnde
'Variablendeklaration
Dim shQuel As Worksheet, shZiel As Worksheet
Dim lngQLR As Long, lngZLR As Long, lngQR As Long
Dim lngCount As Long
'Tabellen benennen
With ThisWorkbook
Set shQuel = Sheets("Tabelle1")
Set shZiel = Sheets("Tabelle2")
End With
'letzte Reihe in Quelle
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row
'Quellreihen durlaufen
'Wenn Nummer in Quelltabelle mehrfach vorhanden
'Reihen rückwärts durchlaufen bei Gleichheit kopieren&löschen
For lngQR = 1 To lngQLR
If shQuel.Cells(lngQR, 1).Value = "" Then Exit For
If WorksheetFunction.CountIf(shQuel.Range("A:A"), _
shQuel.Cells(lngQR, 1).Value) > 1 Then
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row
dieFarbe = Int((200 * Rnd) + 1)
For lngCount = lngQLR To lngQR Step -1
If shQuel.Cells(lngCount, 1).Value = shQuel.Cells(lngQR, 1).Value Then
lngZLR = shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range(shQuel.Cells(lngCount, 1), shQuel.Cells(lngCount, 3)).Copy
shZiel.Cells(lngZLR, 1).PasteSpecial Paste:= _
xlPasteValuesAndNumberFormats
Range(shQuel.Cells(lngCount, 1), shQuel.Cells(lngCount, 3)) _
.Interior.ColorIndex = dieFarbe
End If
Next
End If
Next
ErrEnde:
'Zwischenablage löschen
Application.CutCopyMode = False
'Verweise aufheben
Set shQuel = Nothing
Set shZiel = Nothing
With Application
.EnableEvents = True 'Events einschalten
.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
.Calculation = xlCalculationAutomatic 'Berechnungsmodus auf auto
.Calculate 'Mappen neu rechnen
End With
End Sub
Gruß
Jochen