Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1100to1104
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Doppelte Einträge in einer Spalte

Doppelte Einträge in einer Spalte
Mattes
Hallo,
ich suche ein Makro, das in einer bestimmen Spalte z.B. Spalte A, alle Zellen die einen Inhalt haben (Zahlen) auf doppelte Einträge vergleicht und die doppelte Zahl in Spalte B anzeigt bzw. kopiert beginnend mit Zelle B1, B2 usw.
Gibt es schon ein Makro in dieser Art bzw. wie kann ich das umsetzten?
Vielen Dank.
MfG
Mattes

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Doppelte Einträge in einer Spalte
16.09.2009 17:24:15
JogyB
Hi.
Bekomme es jetzt nicht so hin, dass alles untereinander steht, aber vielleicht reicht es ja so.
In Zelle B1 kommt:
=WENN(ISTFEHLER(VERGLEICH(A1;A2:$A$13;0));"";A1)
In Zelle B2 kommt:
=WENN(ODER(ISTFEHLER(VERGLEICH(A2;A3:$A$13;0));NICHT(ISTFEHLER(VERGLEICH(A2;$B$1:B1;0))));"";A2)
Die Formel dann runterkopieren.
In Spalte B stehen dann die Werte, die mehrfach vorkommen - und zwar immer nur beim ersten Auftreten des Wertes in Spalte A. Ist es Dir lieber, wenn die bei jedem Auftreten stehen, dann die Formel aus B1 runterkopieren.
Gruss, Jogy
Nachtrag...
16.09.2009 17:25:58
JogyB
Hi.
Die leeren Zellen in Spalte B kannst Du ja mit dem Autofilter ausblenden.
Gruss, Jogy
Anzeige
VBA Variante
16.09.2009 18:04:36
Tino
Hallo,
hier was mit VBA
Sub Beispiel()
Dim Bereich As Range, meAr, Dic As Object
Dim A As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Tabelle1") 'Tabellennamen anpassen
Set Bereich = Range("A1", Cells(Rows.Count, 1).End(xlUp))
meAr = Bereich
With Application.WorksheetFunction
For A = 1 To UBound(meAr)
If meAr(A, 1)  "" Then
If .CountIf(Bereich, meAr(A, 1)) > 1 Then
Dic(meAr(A, 1)) = 0
End If
End If
Next A
End With
.Range("B1").Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
End With
End Sub
Gruß Tino
AW: VBA Variante
17.09.2009 17:43:19
Mattes
Hallo,
super Danke. Klappt alles.
Aber ich müßte so wie ich heute erfahren habe das Makro noch weiter optimieren.
Es bleibt bei Spalte A (ab Zeile 231) alle merhfach vorhandenen Einträge (Zahlen) zu finden.
Diese Zahlen sollen nun auf ein zweites Tabellenblatt (Tabelle2) ab der Zelle U21 eingetragen werden.
zusätzlich soll ein Datum das in Tabelle1 in der Spalte G und in der gleichen Zeile wie die doppelte Zahl in Zelle V21 im Tabellenblatt2 kopiert werden.
Beispiel: in Zelle A5 steht die Zahl 25, diese Zahl kommt auch in Zelle A45 und A99 vor, zusätzlich steht in der Zelle G5, sowie in G45 und G99 jeweils ein Datum.
Nun soll die Zahl 25 in das zweite Tabellenblatt in die Zelle U21 kopiert werden (alle weiteren Zahlen die doppelt oder mehrfach vorhanden sind dann auf U22, U23 usw. zu kopieren) und die 3 Einträge des Datums (da ja die Zahl 25 3x vorkommt) dann zusätzlich in die Spalte V21 z.B. das Datum aus Zelle G5 nach V21, G45 nach V22 und G99 nach V23 kopiert werden.
Hoffe das dies verständlich und möglichist.
Vielen Dank für Eure Hilfe.
VG
Mattes
Anzeige
geht es so?
17.09.2009 19:24:26
Tino
Hallo,
ich hoffe das ich dich richtig verstanden habe.
Sub Beispiel()
Dim Bereich As Range, meAr, meAr1, meAr2(), Dic As Object, ArDic
Dim A As Long, B As Long, C As Long, vRow

    Set Dic = CreateObject("Scripting.Dictionary")
    
    'Bereich feststellen *************************** 
    With Sheets("Tabelle1") 'Tabellennamen anpassen 
       
       Set Bereich = .Range("A231", .Cells(.Rows.Count, 1).End(xlUp))
       
       If Not Intersect(Bereich, .Rows("1:230")) Is Nothing Then
        MsgBox "Keine Daten ab A231 vorhanden"
        Exit Sub
       End If
    
    End With

   meAr = Bereich
   'suche doppelte ********************************* 
    With Application.WorksheetFunction
      For A = 1 To Ubound(meAr)
        If meAr(A, 1) <> "" Then
             If .CountIf(Bereich, meAr(A, 1)) > 1 Then
              Dic(meAr(A, 1)) = 0
             End If
        End If
      Next A
    End With
    
    A = 0
    meAr1 = Range(Bereich, Bereich.Offset(0, 1))
    
    If Dic.Count > 0 Then
     C = Dic.Count
     Redim Preserve meAr2(1 To C, 1 To 2)
     ArDic = Dic.keys
     B = 2
    End If
    'suche die Daten zu den doppelten ************************************* 
    For A = 0 To Dic.Count - 1
      vRow = Application.Match(ArDic(A), meAr, 0)
            Do While IsNumeric(vRow)
                If B > Ubound(meAr2, 2) Then Redim Preserve meAr2(1 To C, 1 To B)
                meAr2(A + 1, B) = meAr1(vRow, 2)
                meAr2(A + 1, 1) = meAr1(vRow, 1)
                meAr(vRow, 1) = ""
                vRow = Application.Match(ArDic(A), meAr, 0)
                B = B + 1
            Loop
      B = 2
    Next A
    
    'Daten in Tabelle schreiben ******************************************* 
    With Application
     .ScreenUpdating = False
     .EnableEvents = False
          With Sheets("Tabelle2") 'Tabellennamen anpassen 
           'leer machen für neue Daten eventuell anpassen 
           .Range("U21", .Cells(.Rows.Count, .Columns.Count)).Value = ""
           If A > 0 Then .Range("U21").Resize(Ubound(meAr2), Ubound(meAr2, 2)) = meAr2
          End With
     .EnableEvents = True
     .ScreenUpdating = True
    End With


End Sub
PS: wieso musst Du sowas machen, wird dies von Dir verlangt obwohl Du es nicht kannst?
Gruß Tino
Anzeige
Korrektur wegen Datum in Spalte G
17.09.2009 21:38:08
Tino
Hallo,
sorry habe irgendwie überlesen, dass die Dtumswerte in Spalte G stehen.
Sub Beispiel()
Dim Bereich As Range, meAr, meAr1, meAr2(), Dic As Object, ArDic
Dim ArDate
Dim A As Long, B As Long, C As Long, vRow

    Set Dic = CreateObject("Scripting.Dictionary")
    
    'Bereich feststellen *************************** 
    With Sheets("Tabelle1") 'Tabellennamen anpassen 
       
       Set Bereich = .Range("A231", .Cells(.Rows.Count, 1).End(xlUp))
       
       If Not Intersect(Bereich, .Rows("1:230")) Is Nothing Then
        MsgBox "Keine Daten ab A231 vorhanden"
        Exit Sub
       End If
    
    End With

   meAr = Bereich
   'suche doppelte ********************************* 
    With Application.WorksheetFunction
      For A = 1 To Ubound(meAr)
        If meAr(A, 1) <> "" Then
             If .CountIf(Bereich, meAr(A, 1)) > 1 Then
              Dic(meAr(A, 1)) = 0
             End If
        End If
      Next A
    End With
    
    A = 0
    meAr1 = Bereich
    ArDate = Bereich.Offset(0, 6) 'Spalte mit Datum 
    
    If Dic.Count > 0 Then
     C = Dic.Count
     Redim Preserve meAr2(1 To C, 1 To 2)
     ArDic = Dic.keys
     B = 2
    End If
    'suche die Daten zu den doppelten ************************************* 
    For A = 0 To Dic.Count - 1
      vRow = Application.Match(ArDic(A), meAr, 0)
            Do While IsNumeric(vRow)
                If B > Ubound(meAr2, 2) Then Redim Preserve meAr2(1 To C, 1 To B)
                meAr2(A + 1, B) = ArDate(vRow, 1)
                meAr2(A + 1, 1) = meAr1(vRow, 1)
                meAr(vRow, 1) = Empty
                vRow = Application.Match(ArDic(A), meAr, 0)
                B = B + 1
            Loop
      B = 2
    Next A
    
    'Daten in Tabelle schreiben ******************************************* 
    With Application
     .ScreenUpdating = False
     .EnableEvents = False
          With Sheets("Tabelle2") 'Tabellennamen anpassen 
           'leer machen für neue Daten eventuell anpassen 
           .Range("U21", .Cells(.Rows.Count, .Columns.Count)).Value = ""
           If A > 0 Then .Range("U21").Resize(Ubound(meAr2), Ubound(meAr2, 2)) = meAr2
          End With
     .EnableEvents = True
     .ScreenUpdating = True
    End With


End Sub
Gruß Tino
Anzeige
AW: Korrektur wegen Datum in Spalte G
18.09.2009 14:18:00
Mattes
Hallo Tino,
super mein aller großten Respekt.
Genau so sollte es sein, funktioniert bestens.
Vielen Dank.
Gruß Mattes
AW: VBA Variante
18.09.2009 10:38:18
Lemmi
Hallo Tino,
Marko meldet einen Fehler :
In einen Laufzeitfehler 424
in Zeile .Range("H4").Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
Was muss ich noch anpassen?
Sub doppelte_Zählen()
Dim Bereich As Range, meAr, Dic As Object
Dim A As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Activsheet 'Sheets("Tabelle1") 'Tabellennamen anpassen
Set Bereich = Range("H6", Cells(Rows.Count, 6).End(xlUp))
meAr = Bereich
With Application.WorksheetFunction
For H = 1 To UBound(meAr)
If meAr(H, 1)  "" Then
If .CountIf(Bereich, meAr(H, 1)) > 1 Then
Dic(meAr(H, 1)) = 0
End If
End If
Next H
End With
.Range("H4").Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
End With
End Sub
GRuß
Lemmi
Anzeige
mehrer Fehler
18.09.2009 11:46:59
Tino
Hallo,
Activsheet gibt es nicht = ActiveSheet
Spalte H = nicht 6 sondern 8
Set Bereich = .Range("H6", .Cells(.Rows.Count, 8).End(xlUp))
Variable H ist nicht Deklariert.
Dim H as Long
Wenn Du mehr wie zwei doppelte bekommst,
werden die Daten ab H6 entsprechend weit überschrieben.
Gruß Tino

326 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige