Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1172to1176
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

dubbletten check

dubbletten check
Thomas
Hi!
Hab eine tabelle mit kunden.
kdnr - kunde
1 - thomas
2 - markus
3 - peter
4 -thomas
5 - karli
6 -thomas
kunden können doppelt vorkommen. so kann es sein das ein kunde mehrere kundennummern hat.
vlookup reicht nicht weil hierbei nur ein eintrag ausgelesen werden kann.
gibt es eine möglichkeit für jeden doppelt geführten kunden die kundennummern auslesen zu lassen
(ca 5000 kunden)
thomas 1,4,6
danke im vorhinein

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: dubbletten check
23.08.2010 19:45:00
Florian
Hi Thomas,
ich machs immer so (Annahme: Doppelte in Spalte A):
- Sortiere Spalte A
- In Zelle B2: wenn(oder(A1=A2;A2=A3);1;0)
- STRG+A, Werte einfügen
- Sortiere nach B
Alle Datensätze, die doppelt vorkommen, haben nun eine 1
Gruss Florian
Anzeige
AW: dubbletten check
27.08.2010 22:18:51
Peter
Hallo Florian,
so geht es in ca. 1,5 Sekunden.
Public Sub Doppelte_finden_V()
Dim WkSh     As Worksheet ' das zu bearbeitende Tabellenblatt
Dim lLetzte  As Long      ' die letzte belegte Zeile
Dim MyDic    As Object    ' das Scripting.Dictionary Object
Dim vTemp_B  As Variant   ' Array für Spalten A und B
Dim vTemp_D  As Variant   ' Array für Spalte D
Dim lIndx_B  As Long      ' Index zum Array
Dim lIndx_D  As Long      ' Index zum Array
Dim vName    As Variant   ' die Namen-Unikate
Dim lMax     As Long      ' maximale Anzahl Kunden-Nr zu einem Namen
Dim lKd_Nr   As Long      ' die Anzahl der doppelten Kunden-Nr. je Name
Dim iSpalte  As Integer   ' Ausgabe-Spalte für die Kunden-Nr.
Dim dZeit    As Double    ' benötigte Zeit anzeigen
   dZeit = Timer  ' die Start-Zeit festhalten
   Set WkSh = ThisWorkbook.Worksheets("Tabelle1")
   
   lLetzte = IIf(IsEmpty(WkSh.Cells(Rows.Count, 2)), _
      WkSh.Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
    
   vTemp_B = WkSh.Range("A2:B" & lLetzte)
   
   Set MyDic = CreateObject("Scripting.Dictionary")
   
   For lIndx_B = 1 To UBound(vTemp_B, 1)
      MyDic(vTemp_B(lIndx_B, 2)) = 0   ' Unikate sammeln
   Next lIndx_B
   
   Application.ScreenUpdating = False
   
   WkSh.Range("D2:Z" & lLetzte).ClearContents ' den Ausgabebereich leeren
   
' die Namen ohne doppelte als Array speichern
   vTemp_D = WorksheetFunction.Transpose(MyDic.Keys)
   
   ReDim vTemp_D(1 To MyDic.Count, 1 To 1)
   For Each vName In MyDic.Keys
      lKd_Nr = lKd_Nr + 1
      vTemp_D(lKd_Nr, 1) = vName
   Next vName
   
' Vergleich der beiden Arrays um die Kunden-Nr. zu finden und anzuzeigen
   
   For lIndx_D = LBound(vTemp_D, 1) To UBound(vTemp_D, 1)
      lKd_Nr = 1
      For lIndx_B = LBound(vTemp_B, 1) To UBound(vTemp_B, 1)
         If vTemp_D(lIndx_D, 1) = vTemp_B(lIndx_B, 2) Then
            lKd_Nr = lKd_Nr + 1
            If lKd_Nr > lMax Then
               lMax = lKd_Nr
               ReDim Preserve vTemp_D(1 To MyDic.Count, 1 To lKd_Nr)
               vTemp_D(lIndx_D, lKd_Nr) = vTemp_B(lIndx_B, 1)
             Else
               vTemp_D(lIndx_D, lKd_Nr) = vTemp_B(lIndx_B, 1)
            End If
         End If
      Next lIndx_B
   Next lIndx_D
   
' das Ergebnis der Auswertung ab Zelle D2 ausgeben
   
   WkSh.Range(Cells(2, 4), Cells(MyDic.Count, lMax + 3)) = vTemp_D
      
   Application.ScreenUpdating = True
   
   MsgBox "benötigte Zeit =  " & Format(Timer - dZeit, "#.000") & "  Sekunden.", _
      64, "   Information für " & Application.UserName
End Sub
Mit der Ausgangslage meiner ersten Antwort.
Gruß Peter
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige