AW: Makro nur auf vorher markierte Zellen anwenden
15.01.2008 22:36:38
Luschi
Hallo Johann,
da bei diesem Makro die Anzahl der Schleifendurchläufe doch sehr hoch ist, habe ich mal ein _
neues Makro gemacht, worin der Find-Befehl zum Suchen gleicher Werte benutzt wird:
Sub Gleiche_Inhalte_Faerben_neu()
Dim rg0 As Range, rg1 As Range, rg2 As Range, rg3 As Range
Dim xAdr As String, GruppenNr As Integer, Farbwert(1 To 20)
Farbwert(1) = 6 'Gelb
Farbwert(2) = 44 'Orange
Farbwert(3) = 34 'Hellblau
Farbwert(4) = 39 'Violett
Farbwert(5) = 3 'Rot
Farbwert(6) = 43 'Grün
Farbwert(7) = 38 'Rosa
Farbwert(8) = 41 'Mittelblau
Farbwert(9) = 15 'Grau
Farbwert(10) = 19 'Braun
Farbwert(11) = 16
Farbwert(12) = 48
Farbwert(13) = 31
Farbwert(14) = 37
Farbwert(15) = 13
Farbwert(16) = 22
Farbwert(17) = 36
Farbwert(18) = 56
Farbwert(19) = 24
Farbwert(20) = 8
'alle Tellen in der Markierung
Set rg0 = Application.Selection
rg0.Interior.ColorIndex = xlNone
GruppenNr = 0
'alle Zellen durchlaufen
For Each rg1 In rg0
'wenn Hintergrundfarbe noch nicht gesetzt ist
If (rg1.Interior.ColorIndex = xlNone) Then
'wenn Zelle nicht leer
If Not IsEmpty(rg1.Value) Then
GruppenNr = GruppenNr + 1
'im Zelleverbund rg2 werden alle Zellen gesammelt, die den gleichen Inhalt haben
Set rg2 = rg1
'1. weitere Zelle suchen mit gleichem Zellinhalt
Set rg3 = rg0.Find(rg1.Value, , xlValues, xlWhole, xlByRows, xlNext)
'wenn noch eine Zelle gefunden
If Not rg3 Is Nothing Then
'Zelladresse merken, da der Find-Befehl im Kreis (Endlos-Schleife) sucht
xAdr = rg3.Address
Do
'gefundene Zelle dem Zellverbund rg2 hinzufügen
Set rg2 = Union(rg2, rg3)
'nächste Zelle suchen mit gleichem Inhalt
Set rg3 = rg0.FindNext(rg3)
'Schleifenende, wenn Find-Befehl in Ausgangszelle zurück ist
'ansonsten weitersuchen
Loop While xAdr rg3.Address
End If
' wenn mehr als eine Zelle im Zellverbund
If rg2.Cells.Count > 1 Then
'Hintergundfarbe setzen
rg2.Interior.ColorIndex = Farbwert(GruppenNr)
End If
End If
End If
Next rg1
'alle Objekte entleeren
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
Set rg0 = Nothing
'Array-Inhalte löschen
Erase Farbwert()
End Sub
Gruß von Luschi
aus klein-Paris