Excel 2013 VBA: Farben sortieren

[sharky51]

Hallo und schönen guten Abend,

habe schon wieder eine Frage und hoffe auf Eure Hilfe.

In Spalte "A" habe ich sehr viele Datensätze (ca. 2500) die auch mehrfach vorkommen.
In den anschließenden Spalten "B-H" stehen aber unterschiedliche Werte und deshalb können auch mehrfach gleiche Datensätze in Spalte "A" nicht sofort gelöscht werden.
Zum besseren Sichtung der Daten und der Übersichtlichkeit wegen würde ich gerne alle gleichen Datensätze farblich markieren.
Das habe ich auch mit dem folgenden Makro so umgesetzt. Die Idee ist nun auf alle gleichfarbigen Zellen zu filtern bzw. sie zusammenzufassen
Ich habe aber keine Idee wie ich das anstellen kann.

Vielleicht hat jemand einen Ansatz für mich....es können aber wie Ihr aus dem Array ersehen könnt sehr viele unterschiedliche Farben vorkommen.

So hier nun der Code:

Code:

Sub Doppelte_markieren_Spalte_A()
 Dim lngZeile As Long
 Dim lngEnde As Long
 Dim strValue As String
 Dim objDupList As Object
 Dim arrFarben As Variant
 Dim intFarben As Integer
 
 arrFarben = Array(3, 4, 5, 6, 7, 8, 9, 10, 15, 12, 14, 17, 22, 23, 24, 28, 33, 40, 42, 44, 45, 46, 37, 38, 39, 48, 50) 'Aufzählung der ColorIndex-Werte entsprechend anpassen
 Set objDupList = CreateObject("Scripting.Dictionary")    'Liste der Duplikate (Key) mit ColorIndex (Item)
 
 lngEnde = Cells(Rows.Count, 1).End(xlUp).Row
 'Alle farbigen Zellen finden und zurücksetzen
 For lngZeile = 7 To lngEnde
   If Cells(lngZeile, 2).Text <> "X" Then
     Cells(lngZeile, 1).Interior.ColorIndex = xlNone 'Alle Farben in Spalte C zurücksetzen
   End If
 Next lngZeile
 
 For lngZeile = 7 To lngEnde
   If Cells(lngZeile, 2).Text <> "X" Then
     strValue = Cells(lngZeile, 1).Text
     If strValue <> "" Then      'Test Zelle nicht Leer
     If Application.CountIf(Range("A1:A" & lngEnde), strValue) > 1 Then
       If objDupList.Exists(strValue) Then
         Cells(lngZeile, 1).Interior.ColorIndex = objDupList.Item(strValue)
       Else
         Cells(lngZeile, 1).Interior.ColorIndex = arrFarben(intFarben)
         objDupList.Add strValue, arrFarben(intFarben)
         intFarben = intFarben + 1
         If intFarben > UBound(arrFarben) Then intFarben = 0
       End If
     End If
   End If
 End If
Next lngZeile
End Sub

[schauan]

Hallöchen,

in 2013 kann man doch nach Farben sortieren, schaue mal beim Autofilter ...

[atilla]

Hallo zusammen,

das Zusammenfassen der Daten müsste doch auch mit einfachem sortieren gehen.

[sharky51]

Hallo,

in 2013 kann man nach Farben mit dem Autofilter sortieren....aber ich habe sehr viele Farben.....wie viele kann man denn da mit einbeziehen?
Außerdem wird die Datei mit verschiedenen Excel-Versionen bearbeitet und sollte deshalb abwärts kompatibel sei.

Vielleicht verstehe ich da etwas falsch, dass das Zusammenfassen der Daten mit einfachem sortieren funktioniert ist mir schon klar.
Aber der Ursprungsort der Daten geht doch dann verloren, will sagen der einzelne Datensatz wird aus der ursprünglichen Datenstruktur herausgelöst und man müsste ihn wieder durch zussätzlichen Aufwand dort hin zurückbringen können. Das geht meiner Auffassung nach nur mit einem Filter den ich temporär einschalten kann.

Vermutlich liege ich meiner Aussage auch völlig daneben.

[atilla]

Hallo,

ich hätte da dann folgende zwei Vorschläge:
-einmal die Zeilen einfach durchnummerieren
-oder in einer Hilfsspalte die Farbzahlen eintragen lassen.

mit zwei zusätzlichen Zeilen in Deinem Code z.B. so:

Sub Doppelte_markieren_Spalte_A()
 Dim lngZeile As Long
 Dim lngEnde As Long
 Dim strValue As String
 Dim objDupList As Object
 Dim arrFarben As Variant
 Dim intFarben As Integer
 
 arrFarben = Array(3, 4, 5, 6, 7, 8, 9, 10, 15, 12, 14, 17, 22, 23, 24, 28, 33, 40, 42, 44, 45, 46, 37, 38, 39, 48, 50) 'Aufzählung der ColorIndex-Werte entsprechend anpassen
 Set objDupList = CreateObject("Scripting.Dictionary")    'Liste der Duplikate (Key) mit ColorIndex (Item)
 
 lngEnde = Cells(Rows.Count, 1).End(xlUp).Row
 'Alle farbigen Zellen finden und zurücksetzen
 For lngZeile = 7 To lngEnde
   If Cells(lngZeile, 2).Text <> "X" Then
     Cells(lngZeile, 1).Interior.ColorIndex = xlNone 'Alle Farben in Spalte C zurücksetzen
   End If
 Next lngZeile
 
 For lngZeile = 1 To lngEnde
   If Cells(lngZeile, 2).Text <> "X" Then
     strValue = Cells(lngZeile, 1).Text
     If strValue <> "" Then      'Test Zelle nicht Leer
     If Application.CountIf(Range("A1:A" & lngEnde), strValue) > 1 Then
       If objDupList.Exists(strValue) Then
         Cells(lngZeile, 1).Interior.ColorIndex = objDupList.Item(strValue)
         Cells(lngZeile, 3) = objDupList.Item(strValue)
       Else
         Cells(lngZeile, 1).Interior.ColorIndex = arrFarben(intFarben)
         Cells(lngZeile, 3) = arrFarben(intFarben)
         objDupList.Add strValue, arrFarben(intFarben)
         intFarben = intFarben + 1
         If intFarben > UBound(arrFarben) Then intFarben = 0
       End If
     End If
   End If
 End If
Next lngZeile
End Sub


Spalte 3 ist in diesem Fall die Hilfsspalte

[sharky51]

Hallo atilla,

vielen Dank für Deinen Vorschlag.

In die Richtung Deines zweiten Vorschlages habe ich auch schon gedacht.
Die Hilfsspalte werde ich ganz ans Ende setzen müssen damit ich den Datensatz nicht "störe"  :)

Ich denke das ist die beste und praktikabelste Lösung.

Vielen Dank nochmals dafür!

[Fennek]

Ohne Ihren Code zu analysieren, wie wäre es eine Tabelle zu definieren, und mit "Schnellanalyse ->Duplikate suchen" zu arbeiten?

[snb]

Dann wäre es einfacher Autofilter zu verwenden:

Code:

sub M_snb()
   sheet1.cells(1).currentregion.advancedfilter 2,,sheet1.cells(1,200),true
   sn=sheet1.cells(1,200).currentregion

   with sheet1.cells(1).currentregion
     for j=2 to ubound(sn)
       .autofilter 1, sn(j,1)
       stop
       .autofilter
     next
   end with
End Sub