Office: Doppelte Wörter zählen bzw. ausblenden mit VBA

Hallo!

Ich habe eine Liste mit sich häufig wiederholenden Wörtern. Ich möchte diese Liste durchgehen und je eine Wort der doppelten Einträge in eine neue Tabelle schreiben. Dabei möchte ich in einer anderen Spalte die Anzahl des "Vorkommens" berechnen, nur wie?

Mit meinem Code filtere ich zwar die liste, allerdings habe ich keine Idee wie ich die Anzahl herausbekommen soll. Dabei muss ich beachten, das ich das Ende der Liste nicht kenne, also erweitert werden kann.

Hier mein momentaner Code:

Code:

Sub ZaehleNeueMeldungen()
  Dim i, j, c, d As Integer
  Dim Zone, Zeit, Neu, NZeit, NeuMeldung As String
  Dim StrEq As Integer
    
  i = 2
  j = 5
  c = 5
  
  Do
    Zone = Worksheets(1).Cells(i, 7).Value
    Zeit = Worksheets(1).Cells(i, 1).Value
    Neu = Worksheets(3).Cells(j, 3).Value
    NeuMeldung = Worksheets(1).Cells(i, 8).Value
    If Worksheets(1).Cells(i, 8).Value = "Neue Meldung" Then
      Do
        If Worksheets(3).Cells(c, 3).Value <> Zone Then
          Worksheets(3).Cells(c, 3).Value = Zone
        End If
        c = c + 1
      Loop Until Len(Worksheets(3).Cells(c, 3).Value) = 0
      'Worksheets(3).Cells(j, 4).Value = Zeit
    End If
    i = i + 1
  Loop Until Len(Zone) = 0
End Sub

Um vielleicht die Frage zu verdeutlichen, hier ein Beispiel:

Code:

eintrag1    
eintrag2    
eintrag1    
eintrag3    
eintrag1    
eintrag2    
eintrag4    

soll zu diesem Ergebnis werden:

Code:

eintrag 1     |   3x
eintrag 2     |   2x
eintrag 3     |   1x
eintrag 4     |   1x

 

Das läuft im Prinzip ganz einfach und ist nur eine Nachbildung dessen, was man "von Hand" auch machen würde:
a) nehme jeden Eintrag aus Liste 1
b) vergleiche diesen mit jedem Eintrag aus Liste 2
c) "gefunden" --> Zähler erhöhen
d) "nicht gefunden" --> Eintrag anhängen an Liste 2, Zähler auf 1

Code:

Private Sub CommandButton1_Click()

    Dim s1, s2 As Worksheet
    Dim y1, x1 As Long: Dim tst1 As String
    Dim y2, x2 As Long: Dim tst2 As String

    Set s1 = ActiveSheet
    Set s2 = ActiveSheet

    s2.Columns("c:d").ClearContents

    y1 = 1: x1 = 1
    s1.Activate: s1.Cells(y1, x1).Activate
    tst1 = Trim$(s1.Cells(y1, x1).Value)
    While (tst1 <> "")

        y2 = 1: x2 = 3
        's2.Activate: s2.Cells(y2, x2).Activate
        tst2 = Trim$(s2.Cells(y2, x2).Value)
        While (tst2 <> "")

            If (tst2 = tst1) Then
                s2.Cells(y2, 4).Value = s2.Cells(y2, 4).Value + 1
                y2 = 65535
            End If

            y2 = y2 + 1: x2 = 3
            's2.Activate: s2.Cells(y2, x2).Activate
            tst2 = Trim$(s2.Cells(y2, x2).Value)
        Wend

        If (y2 < 65535) Then
            s2.Cells(y2, 3).Value = tst1
            s2.Cells(y2, 4).Value = 1
        End If

        y1 = y1 + 1: x1 = 1
        s1.Activate: s1.Cells(y1, x1).Activate
        tst1 = Trim$(s1.Cells(y1, x1).Value)
    Wend

End Sub

Die Variablen, die mit "1" enden, gehören zu Punkt a), die mit "2" am Ende gehören zu b) Das "if" in der Mitte wird bei "gefunden" ausgeführt, das "if" am Ende wird bei "nicht gefunden" ausgeführt.

Gruß, Michael

 

Hallo!

Das geht auch gänzlich ohne VBA!
Mit einer Pivot-Tabelle bist du mit ein paar Mausklicks am Ziel:
Markiere die Daten (Überschrift muss vorhanden sein!).
Wähle Menü Daten > Pivot-Table und folge dem Assistenten.
Ziehe zum Schluss dein Daten-Feld einmal in den Zeilenbereich und einmal in den Datenbereich.
Fertig!