VB Excel - Mehrfacheinträge

[Krool]

Hallo ihr!

Bin an einem Makro dran in Excel.
Zweck ist an einer bestimmten Spalte alle vorkommenden Dublikate (mehrfacheinträge) rot zu färben.
Diesen Zweck erfüllt das Makro wunderbar.
Nun wollte ich es erweitern mit der Funktion "Zuordnung". Also ich deklariere einen Zuordnungsbegriff z.b. "C". Ich sage dem Script auch per eingabefeld in welcher spalte sich die "Zuordnungs Spalte" befindet. Nun soll das Makro alle Felder die doppelt vorhanden sind rot färben soweit die Zuordnung (also die eingabe) mit der "zuordnungs Spalte" übereinstimmt.
Ergebniss = Es funktioniert bedingt. also nur manchmal und ich bin nicht dahinter gekommen wieso nicht immer.
In der Excel datei hab ich 2 möglichkeiten beschrieben das zu testen um zu sehen das es bei der 1. klappt aber bei der 2. nicht.
(Download entfernt, da Problem gelöst)

Wenn die abfrage kommt beim starten "bereinigen der tabelle"? dann mit Nein antworten. weil da ist mein beispiel drin.
Und nach der 1. möglichkeit alle zellen markieren und die farbe löschen. dann erst mit der 2. möglichkeit beginnen.

Vielen dank an die die mir helfen wollen.

Gruß!

[Nor]

Mir sind einige Dinge darin unklar... leider gibts keine Kommentare im Source, was es recht schwierig macht.
Allgemein außerdem der Tip keine Sprungmarken zu verwenden. Sich wiederholende Vorgänge lieber als eigene Funktionen schreiben. Ist sauberer.

ok.. damit ich erst mal verstehe, was du da tust (und warum), folgende Fragen:

Code:

SpaltenZuordnung = SpaltenZuordnung - 1

Why -1 ? Soweit ich das verstehe, geht es um die Spalte in der die Zuordnung enthalten sein soll... die gibt der User ja selbst ein. Warum ziehst du da 1 ab?

Endgültig verwirrt mich dann

Code:

If Cells(ReihenSprung, Spalte + SpaltenZuordnung) = Zuordnung Then

Kann gut sein, dass ich da was überseh, aber mir ists etwas unklar.
Ich bin mir nicht ganz sicher warum du "Spalte + SpaltenZuordnung" verwendest um die Zelle anzusprechen. Du willst doch an der jeweiligen Stelle gezielt auf die Zelle der "Zuordnungsspalte" zugreifen.
Sollte es nicht mit Cells(ReihenSprung, SpaltenZuordnung) eher klappen?
Mir scheint es fast so als würdest du mit diesen zwei Dingen grad im Versuchsbeispiel Glück haben - weil du zuerst eins abziehst und dann (weil im Versuchsbeispiel die zu untersuchende Spalte die 1. ist) wieder 1 dazuzählen. Ich hab sowohl das -1 weggenommen als auch das "Spalte +".
Ergebnis:
Es ist natürlich nicht die Lösung deines Problems.. aber das Ding verhält sich zumindest noch so wie vorher. Ich bin mir also nicht ganz sicher, ob das keine Fehler waren, die sich nur einfach noch nicht gezeigt haben.
Aber wie gesagt: Kann auch gut sein, dass ich mich irre und lasse mich natürlich auch gerne eines Besseren belehren. Bis dahin lass ich den Code aber so.


Zudem glaube ich, dass es besser wäre den Inhalt der Zelle mit .value anzusprechen.
Also

Code:

If Cells(ReihenSprung, SpaltenZuordnung).value = Zuordnung

statt

Code:

If Cells(ReihenSprung, SpaltenZuordnung) = Zuordnung

oder wie es in deinem Fall noch steht:

Code:

If Cells(ReihenSprung, Spalte + SpaltenZuordnung) = Zuordnung

Aber auch das ist nicht der eigentliche Fehler. Es ist nur sauberer IMHO.

Wirklich schwer wirds für mich, nachzuvollziehen warum du "CountIf" einsetzt. Diese Funktion gibt, soweit ich das jetzt rausfinden konnte, zurück WIEVIELE Zellen deiner Auswahl entsprechen. Das bringt aber sowieso insofern IMHO gar nichts, als dass du dadurch eigentlich gar nicht wirklich weißt, WELCHE das nun sind. Dass das Ganze dennoch funktioniert, wundert mich ehrlich gesagt ein wenig.
Ich würde den ganzen Algorithmus ganz anders machen... in zwei Schleifen nämlich. Die erste Schleife geht Zelle für Zelle durch (wie dus ja schon machst) und holt sich immer den Wert der jeweiligen Zelle... darin wird dann nochmals eine "Unterschleife" gestartet, die dann für sich ebenfalls Zelle für Zelle durchgeht und nachsieht ob dieser Wert als solcher ebenfalls woanders vorkommt.
.....
..
Je mehr ich jetzt drüber nachdenke, desto klarer wirds mir:
Du gehst Reihe für Reihe durch, nimmst den Wert immer wieder als einzelnen her und checkst mit der CountIf Funktion von Excel ob dieser Wert öfters vorkommt. Und wenn ja, dann färbst du (obwohl du dann auch IMHO nicht

Code:

If Application.WorksheetFunction.CountIf(Range(Cells(1, Spalte), Cells(Reihe, Spalte)), _
SuchKriterium) <> 1 Then

sondern eher

Code:

If Application.WorksheetFunction.CountIf(Range(Cells(1, Spalte), Cells(Reihe, Spalte)), _
SuchKriterium) > 1 Then

schreiben solltest... ist zwar eh net möglich, dass der Wert 0 ist (da er sonst gar nicht erst eingelesen hätte werden können).. aber es ist trotzdem sauberer.

Aber genau hier liegt der Fehler:
Du checkst "WAS IST DOPPELT?" und "HAT ZURODNUNGSBEGRIFF [X]".
Und genau das macht er dann auch... er sieht nach, was öfter als 1 Mal gefunden wird und markiert dann all jene von den doppelten Begriffen rot, die als Zuordnung Begriff [X] haben.

In deinem Beispiel:
Du willst alles markieren, was doppelt ist, vorrausgesetzt es hat den Buchstaben "C" in der Zuordnungsspalte. Und zwar ebenfalls mehr als nur einmal.
Dein Makro prüft aber zunächst "was ist doppelt" (zum Beispiel ist ja auch die Zahl 8 doppelt... weil hier ja noch gar nicht berücksichtigt wird, ob die Zahl 8 auch in Zusammenhang mit dem Buchstaben C in der Zuordnungsspalte doppelt vorkommt) und markiert dann bei allen doppelt gefundenen jene, die den Buchstaben "C" drinnen haben.
Deshalb markiert er auch schön brav die Zahl 8 (in Zelle A9). DENN: 8 kommt mehr als einmal vor... und in Zelle A9 hat die Zahl 8 in der Zuordnungsspalte den Buchstaben C.

Ich hoffe dir ist jetzt klar was ich meine.
ALSO:
Verwende, statt die Duplettenprüfung lediglich "CountIf" zu überlassen eine zweite Schleife dafür, die die Zellen für sich nochmals durchgeht.
Beim ersten Fund einer Zahl in Zusammenhang mit der Zuordnung, soll sie deren Zelle in eine Variable schreiben. Findet es sie ein zweites Mal, soll sie sie rot machen (und bei jedem zukünftigem Fund ebenfalls). Am Ende macht Sie noch die rot, die du eben in der Variable gespeichert hast.
Ich weiß, dass das jetzt kompliziert ist.. aber ich kanns net besser beschreiben.

Deshalb hier der Source ^^":

Code:

Option Explicit

'Author = Krool (mit freundlicher Unterstüzung von Nor)
'Version = 1.0 lng = Ger

Sub Dublikate()
On Error GoTo Abbrechen
Dim Spalte As Long
Dim Eingabe As Variant
Dim BeginneMit As Variant
Dim ErgebnissSchritt As Long
Dim ErgebnissZähler As Long
Dim Zuordnung As String
Dim SpaltenZuordnung As Long
Dim SpaltenZuordnungEingabe As Variant
Dim ZuordnungJa As Integer
Wiederholen1:
Eingabe = InputBox("Welche Spalte auf Mehrfacheinträge hin überprüfen?" & vbLf & _
"1 = A bis 256 = IV" & vbLf & _
"888 = >Beginne mit Spalte< Methode" & vbLf & _
"999 = >Zuordnungs< Methode (BETA)", "Eingabe", "1")
Select Case Eingabe
Case 1 To 256
Case ""
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
Case 888
Wiederholen2:
BeginneMit = InputBox("Mit welcher Spalte willst du beginnen?" & vbLf & _
"1 = A bis 256 = IV" & vbLf & _
"Nach jeder berechneten Spalte wirst du gefragt ob du fortfahren willst.", _
"Eingabe >Beginne mit Spalte< Methode", "1")
Select Case BeginneMit
Case 1 To 256
Case ""
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
Case Else
MsgBox "Eingabe nicht zu gebrauchen." & vbLf & _
"Bitte wiederholen Sie den Vorgang.", vbCritical + vbOKOnly, "Fehlerhafte Eingabe"
GoTo Wiederholen2
End Select
Case 999
Wiederholen3:
Eingabe = InputBox("Welche Spalte auf Mehrfacheinträge hin überprüfen?" & vbLf & _
"1 = A bis 256 = IV", "Eingabe >Zuordnungs< Methode", "1")
Select Case Eingabe
Case 1 To 256
Case ""
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
Case Else
MsgBox "Eingabe nicht zu gebrauchen." & vbLf & _
"Bitte wiederholen Sie den Vorgang.", vbCritical + vbOKOnly, "Fehlerhafte Eingabe"
GoTo Wiederholen3
End Select
Wiederholen4:
Zuordnung = InputBox("Gebe den Zuordnungsbegriff ein." & vbLf & _
"Auf die Groß- und Kleinschreibung achten!", "Zuordnungsbegriff", "Zuordnungsbegriff")
If Zuordnung = "" Then
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
End If
Wiederholen5:
SpaltenZuordnungEingabe = InputBox("In welcher Spalte befindet sich die Zuordnung?" & vbLf & _
"1 = A bis 256 = IV" & vbLf & _
"Vordefinierte Zahl ist Spalte die überprüft wird + 1.", _
"Eingabe >Zuordnungs< Methode", Eingabe + 1)
Select Case SpaltenZuordnungEingabe
Case 1 To 256
SpaltenZuordnung = SpaltenZuordnungEingabe
ZuordnungJa = 1
SpaltenZuordnung = SpaltenZuordnung
Case ""
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
Case Else
MsgBox "Eingabe nicht zu gebrauchen." & vbLf & _
"Bitte wiederholen Sie den Vorgang.", vbCritical + vbOKOnly, "Fehlerhafte Eingabe"
GoTo Wiederholen5
End Select
Case Else
MsgBox "Eingabe nicht zu gebrauchen." & vbLf & _
"Bitte wiederholen Sie den Vorgang.", vbCritical + vbOKOnly, "Fehlerhafte Eingabe"
GoTo Wiederholen1
End Select
If BeginneMit > 0 Then
Spalte = BeginneMit
Else
Spalte = Eingabe
End If
Application.ScreenUpdating = False
NächsteSpalte:
Dim Reihe As Long
Dim ReihenSprung As Long
Dim SuchKriterium As String
Reihe = Cells(Rows.Count, Spalte).End(xlUp).Row


For ReihenSprung = Reihe To 1 Step -1
Dim ueberpruefen As Long
ueberpruefen = 0


SuchKriterium = Cells(ReihenSprung, Spalte).Value

'Wir speichern das Suchkriterium in einer Variable. Nun könnten wir durchgehen und die Dupletten
'zu diesem Suchkriterium suchen. Das tun wir aber NUR, wenn wir als zusätzliche Einschränkung nicht
'angegeben haben, dass das Zuordnungskriterium erfüllt sein soll.
'Ist dies hingegen der Fall, prüfen wir zunächst mal ob die Zuordnung für diese Zelle überhaupt da ist.

If ZuordnungJa = 1 Then

    If Cells(ReihenSprung, SpaltenZuordnung).Value = Zuordnung Then

        ueberpruefen = 2
    End If
Else
        ueberpruefen = 1
End If



'Wir haben nun das Surchkriterium und gehen damit nun in einer "Unterschleife" Spalte für Spalte durch, um
'zu checken, ob eben dieses Suchkriterium auch in einer anderen Spalte vorhanden ist.

If ueberpruefen > 0 Then

    Dim zweiterReihensprung As Long
    For zweiterReihensprung = Reihe To 1 Step -1
    If zweiterReihensprung <> ReihenSprung Then 'Natürlich wird in der Unterschleife die aktuelle Celle der oberen Schleife übersprungen
        If Cells(zweiterReihensprung, Spalte).Value = SuchKriterium Then
    
            Dim faerbenOderNichtfaerben As Boolean
            faerbenOderNichtfaerben = True
        
            'Standardmäßig sagen wir hier "FÄRBEN", weil wir an dieser Stelle ja nun wissen
            'dass dieser Eintrag eben zumindest doppelt ist.
            'Dennoch behalten wir uns das Recht vor, mittels dieser Variable später noch zu sagen
            '... "NE! Doch nicht"
        
          
            'ABER STOP! ZUNÄCHST SEHEN WIR ERSTMAL NACH, OB WIR NICHT NOCH EINEN ZUORDNUNGSBEGRIFF
            'EINHALTEN MÜSSEN... In dem Fall ist die Variable ueberpruefen auf den Wert "2" gesetzt.
            If ueberpruefen = 2 Then
                If Cells(zweiterReihensprung, SpaltenZuordnung).Value <> Zuordnung Then
                    'nun können wir also nochmal sagen - NEIN.. doch kein Färben, weil
                    'der Zurodnungsbegriff nicht in der Zuordnungspalte ist.
                    
                     faerbenOderNichtfaerben = False
                End If
            End If
            'Sollen wir färben?
            
            If faerbenOderNichtfaerben = True Then
               
            'JA! Dieser Eintrag ist also zumindest doppelt (und bei Bedarf auch mit der
            'gewünschten Zuordnung doppelt. Also färben wir die aktuelle
            'Zeile aus der "zweiterReihensprung"-Schleife rot. Und wir färben natürlich
            'auch die aktuelle Zelle aus der übergeordneten Schleife rot, da wir JETZT ja
            'wissen, dass diese eben wirklich auch doppelt vorkommt. Diese Zelle wird
            'dann übrigens bei jedem weiteren Doppelfund innerhalb dieser Schleife nochmals
            'rot gefärbt - aber das macht ja nix ^^".
                If (IsEmpty(Cells(zweiterReihensprung, Spalte))) Then
                    Cells(zweiterReihensprung, Spalte).Interior.ColorIndex = xlNone
                Else
             
                    Cells(ReihenSprung, Spalte).Interior.ColorIndex = 3
                    Cells(zweiterReihensprung, Spalte).Interior.ColorIndex = 3
                End If

            
            End If
            
            
            
        End If
        
        
    End If
    Next zweiterReihensprung


End If
Next ReihenSprung
If BeginneMit > 0 Then
ErgebnissZähler = 0
For ErgebnissSchritt = 1 To Rows.Count Step 1
If Not Cells(ErgebnissSchritt, Spalte).Interior.ColorIndex = xlNone Then
ErgebnissZähler = ErgebnissZähler + 1
End If
Next ErgebnissSchritt
Application.ScreenUpdating = True
MsgBox "Es befinden sich " & ErgebnissZähler & " mehrfacheinträge in Spalte " & _
Spalte & ".", vbInformation + vbOKOnly, "Ergebniss"
Spalte = Spalte + 1
If Spalte > 256 Then
MsgBox "Maximale Spaltenzahl in Excel erreicht." & vbLf & _
"Vorgang kann nicht fortgesetzt werden.", vbExclamation + vbOKOnly, "Information"
GoTo Abbrechen
End If
If MsgBox("Fortfahren mit Spalte " & Spalte & "?", vbInformation + vbYesNo, _
"Fortfahren") = vbYes Then
Application.ScreenUpdating = False
GoTo NächsteSpalte
Else
Application.ScreenUpdating = True
MsgBox "Vorgang beendet.", vbInformation + vbOKOnly, "Abbruch"
Exit Sub
End If
End If
For ErgebnissSchritt = 1 To Rows.Count Step 1
If Not Cells(ErgebnissSchritt, Spalte).Interior.ColorIndex = xlNone Then
ErgebnissZähler = ErgebnissZähler + 1
End If
Next ErgebnissSchritt
Application.ScreenUpdating = True
If ZuordnungJa = 1 Then
MsgBox "Es befinden sich " & ErgebnissZähler & " mehrfacheinträge in Spalte " & _
Spalte & vbLf & "mit der Zuordnung " & Zuordnung & " in Spalte " & SpaltenZuordnung + 1 & _
".", vbInformation + vbOKOnly, "Ergebniss"
Else
MsgBox "Es befinden sich " & ErgebnissZähler & " mehrfacheinträge in Spalte " & _
Spalte & ".", vbInformation + vbOKOnly, "Ergebniss"
End If
Abbrechen:
Application.ScreenUpdating = True
End Sub

[Krool]

Hi,

Bin jetzt erst dazu gekommen deinen Post zu lesen. VIELEN DANK!!!!
Es funktioniert perfekt und schnelle Laufzeit. also mir scheint es noch kürzer zu dauern.
Hab noch die Statistikschleife mit der "Reihe" Variable verknüpft mit Step -1 .
Dann geht er nicht alle 65536 Zellen durch. nochmals ein Speed zuwachs.
Hab noch bei der Statistik Message am schluß das " + 1 " entfernt bei
" SpaltenZuordnung + 1 ".
Wirklich beeindruckend das du dich da reingearbeitet hast. Nochmals THX!


Gruß

[Nor]

Freut mich, dass es passt.
Gerne doch . Jederzeit wieder. *g*