Liste ohne Dublikate aus einer Matrix

  • Excel

Es gibt 6 Antworten in diesem Thema. Der letzte Beitrag () ist von DaCapitalist.

    Liste ohne Dublikate aus einer Matrix

    Hallo zusammen!

    Ich bin leider VBA-Anfänger und konnte mir bisher nur einzelne Code-Schnipsel zusammen suchen und dann anpassen.
    Bei dieser Frage übersteigen die Anforderungen leider meinen Kenntnisstand.

    Ich versuche, aus einer externen Excel-Tabelle jede zweite Spalte innerhalb eines Bereiches ab inkl. Spalte G in ein Dictionary einzulesen und danach in der eigenen Tabelle ohne Duplikate untereinander auszugeben.

    Bei meinem Code gibt es allerdings einen Array-Fehler. Und auch sonst komme ich nicht weiter.

    Quellcode

    1. Sub Daten_holen()
    3. Dim i, r As Long
    4. Dim oDict As Object
    6. Set Source = GetObject(ActiveWorkbook.Worksheets("Optionen").Range("D16").Value) 'Pfad der Projekt-Liste in Zelle D16
    7. Set oDict = CreateObject("scripting.dictionary")
    8. Const intZ = 2 'Import ab Zeile 2 der Zieltabelle
    11. 'Idee: While-Schleife, um Dictionary erstmal mit allen Projekten zu füttern und Duplikate zu entfernen
    13. With Source.Worksheets("Assignment")
    14. For i = 7 To .Columns.Count Step 2
    15. For r = 5 To .Cells(Rows.Count, 1).End(xlUp).Row 'ab Zeile 5 (Überschrift weglassen)
    16. If Len(Trim(.Cells(r, i))) Then oDict(.Cells(r, i).Text) = "" 'Spalte 2
    17. Next r
    18. Next i
    19. End With
    21. ActiveWorkbook.Worksheets("Projektliste").Cells(intZ, 1).Resize(oDict.Count, 1) = Application.Transpose(oDict.keys)
    23. End Sub


    Es wäre klasse, wenn mir hier jemand helfen könnte.

    Vielen Dank!

    DaCapitalist schrieb:

    Bei meinem Code gibt es allerdings einen Array-Fehler
    Welche Zeile?

    Btw:
    Was ist ActiveWorkbook? Das, in dem der Code läuft?
    Oder ein Fremdes? Wenn ja, wie ist es geöffnet worden?

    ​Set Source = GetObject(ActiveWorkbook.Worksheets("Optionen").Range("D16").Value) 'Pfad der Projekt-Liste in Zelle D16
    ist eine äusserst merkwürdige Konstruktion und kann sicher wesentlich verbessert werden, wenn du die obigen Fragen beantwortet hast.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Danke für die schnelle Antwort!

    ActiveWorkbook ist das, aus dem der Code aufgerufen wurde. Dort drin liegt eine Zelle, die den Pfad zur externen Datei enthält (Damit man diesen später ohne coden ändern kann, wenn die Datei auf einen anderen Computer kopiert wird). Diese Zelle wird in deinem zweiten Zitat referenziert.

    Genau richtig. Es geht nur darum, die Datei irgendwo speichern zu können. Ohne, dass man einen bestimmten Pfad wählen muss, wenn man kein VBA beherrscht.

    Hier nochmal ein Update, welches auch korrekt durchläuft (wenn auch recht langsam).
    Es fehlt im Grunde nur noch die Dynamisierung des Dateipfades:

    Quellcode

    1. Sub Daten_holen()
    3. Dim i, r As Long
    4. Dim oDict_Names As Object 'Projektnamen
    5. Dim oDict_Numbers As Object 'Projektnummern
    7. 'Set Source = GetObject(ActiveWorkbook.Worksheets("Optionen").Range("D16").Value) 'Pfad der Projekt-Liste in Zelle D16
    8. Set oDict_Names = CreateObject("scripting.dictionary")
    9. Set oDict_Numbers = CreateObject("scripting.dictionary")
    11. 'Idee: While-Schleife, um Dictionary erstmal mit allen Projekten zu füttern und Duplikate zu entfernen
    13. 'Projektnamen sammeln
    14. 'With Source.Worksheets("Assignment")
    15. With Workbooks("Projektliste.xlsx").Worksheets("Assignment")
    16. For i = 7 To .Columns.Count Step 2
    17. For r = 5 To .Cells(Rows.Count, 1).End(xlUp).Row 'ab Zeile 5 (Überschrift weglassen)
    18. If (Not IsError(.Cells(r, i))) Then 'Bezugfehler überspringen
    19. If Len(Trim(.Cells(r, i))) Then oDict_Names(.Cells(r, i).Text) = "" 'Spalte
    20. End If
    21. Next r
    22. Next i
    23. End With
    25. 'Projektnummern sammeln
    26. 'With Source.Worksheets("Assignment")
    27. With Workbooks("Projektliste.xlsx").Worksheets("Assignment")
    28. For i = 8 To .Columns.Count Step 2
    29. For r = 5 To .Cells(Rows.Count, 1).End(xlUp).Row 'ab Zeile 5 (Überschrift weglassen)
    30. If (Not IsError(.Cells(r, i))) Then 'Bezugfehler überspringen
    31. If Len(Trim(.Cells(r, i))) Then oDict_Numbers(.Cells(r, i).Text) = "" 'Spalte
    32. End If
    33. Next r
    34. Next i
    35. End With
    37. 'Einfügen in Zeile 2 und Spalte 1 der Zieltabelle [NAMES]
    38. ActiveWorkbook.Worksheets("Projekte").Cells(2, 1).Resize(oDict_Names.Count, 1) = Application.Transpose(oDict_Names.keys)
    40. 'Einfügen in Zeile 2 und Spalte 2 der Zieltabelle [NUMBERS]
    41. ActiveWorkbook.Worksheets("Projekte").Cells(2, 2).Resize(oDict_Numbers.Count, 1) = Application.Transpose(oDict_Numbers.keys)
    44. End Sub

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „DaCapitalist“ ()

    ??
    Du hast ein Workbook "Projektliste.xlsx", aus dem du das Dictionary füllst und hast ein
    ActiveWorkbook, in dem der Code läuft und in das du speicherst.

    Das Projektliste-Workbook ist wohl schon offen?
    Zumindest sehe ich in deinem Code kein explizites Open.

    Mein Ansatz wäre da wahrscheinlich vom Grundansatz in etwa so:

    Visual Basic-Quellcode

    1. ​
    2. Set SourceWB = Workbook.Open("Projektliste.xlsx", ReadOnly :=True) 'besser mit Pfadangabe
    3. Set SourceWS = SourceWB.Worksheets("Assignment")
    4. With SourceWS
    5. ' fill dictionary
    6. End With
    7. Set DestWS = ThisWorkbook.Sheets("Projekte")
    8. ' write to DestWS


    Allerdings verstehe ich den Umweg über zwei Dictionaries nicht so richtig.
    Ein Dictionary beinhaltet normalerweise Wertepaare, von denen du nur eines füllst.
    Deine Gedankengänge überlasten mich.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Danke für die Antwort und sorry, dass meine etwas auf sich warten ließ.
    Ich habe zwischenzeitlich ein selbst ein wenig weitergeforscht und schaffe es mittlerweile, den Code weit fortlaufen zu lassen. Nun wird das Dictionary auch etwas mehr ausgenutzt.
    Bei einer weiteren Funktion in Zeile 103 gibt er mir aber jedes Mal einen Fehler aus, dass die Zuweisung ungültig ist - als würde er keinen Key aus dem Dict übergeben bekommen. Obwohl es ja vorher erfolgreich gefüllt wird. (Ich habe das mit der Konsolenausgabe bereits getestet)

    Kannst du damit etwas anfangen? Die For-each-Schleife wird nur wenig weiter oben ja exakt genauso definiert.

    Quellcode

    1. Sub Daten_holen()
    3. 'Variablen für Import von Projekten
    4. Dim i, r As Long
    5. Dim oDict_Numbers As Object 'Projektnummern
    6. Dim oDict_Berater As Object 'Projekt-/Berater-Verzeichnis
    8. Set oDict_Numbers = CreateObject("scripting.dictionary")
    10. 'Idee: While-Schleife, um Dictionary erstmal mit allen Projekten zu füttern und Duplikate zu entfernen
    12. 'Projektnummern und KW sammeln
    13. Debug.Print "Sammle Projektnummern und Kalenderwochen..."
    14. With Workbooks("Projektliste.xlsx").Worksheets("Assignment")
    15. For i = 8 To .Columns.Count Step 2
    16. For r = 5 To .Cells(Rows.Count, 1).End(xlUp).Row 'ab Zeile 5 (Überschrift weglassen)
    17. If (Not IsError(.Cells(r, i))) Then 'Bezugfehler überspringen
    19. 'Leere Zeilen ignorieren
    20. If Len(Trim(.Cells(r, i))) Then
    22. 'Checken, ob Wert in Dictionary vorhanden
    23. If oDict_Numbers.Exists(.Cells(r, i).Text) Then
    24. 'Checke ob Spaltennummer höher als der dict.Value zu dieser Projektnummer, dann schreibe Wert ins Dict
    25. If oDict_Numbers.Item(.Cells(r, i).Text) < i Then oDict_Numbers.Item(.Cells(r, i).Text) = i
    26. Else
    27. 'Zu Dictionary hinzufügen
    28. oDict_Numbers.Item(.Cells(r, i).Text) = i 'Spalte
    29. End If
    31. End If
    33. End If
    34. Next r
    35. Next i
    36. End With
    38. 'Berater und Rollen sammeln
    39. Berater_sammeln
    41. 'Einfügen in Zeile 2 und Spalte 1 der Zieltabelle [NAMES]
    42. 'ActiveWorkbook.Worksheets("Projekte").Cells(2, 1).Resize(oDict_Names.Count, 1) = Application.Transpose(oDict_Names.Keys)
    44. 'Einfügen in Zeile 2 und Spalte 2 der Zieltabelle [NUMBERS]
    45. 'ActiveWorkbook.Worksheets("Projekte").Cells(2, 2).Resize(oDict_Numbers.Count, 1) = Application.Transpose(oDict_Numbers.Keys)
    47. 'Projektnummern bereinigen und in Import-Sheet + KWs
    48. For Each strKey In oDict_Numbers.Keys()
    49. If Not IsNumeric(strKey) Then oDict_Numbers.Remove (strKey)
    50. Next
    51. ActiveWorkbook.Worksheets("Projekte_neu").Cells(2, 1).Resize(oDict_Numbers.Count, 1) = Application.Transpose(oDict_Numbers.Keys)
    52. ActiveWorkbook.Worksheets("Projekte_neu").Cells(2, 3).Resize(oDict_Numbers.Count, 1) = Application.Transpose(oDict_Numbers.Items)
    54. 'Berater-Liste für jedes Projekt erstellen #######################################################################################
    55. Set oDict_Berater = CloneDictionary(oDict_Numbers)
    57. With Workbooks("Projektliste.xlsx").Worksheets("Assignment")
    59. 'Kopiere Projektliste in ein neues Dictionary (Values werden später mit den Namenslisten ersetzt
    60. Debug.Print "Sammle Berater für Projekte..."
    62. For Each strKey In oDict_Berater.Keys
    64. Debug.Print "Lese Berater für: " & strKey
    66. 'Jedes Projekt bekommt eine Beraterliste (ggf. durch Array ersetzen)
    67. Set berater = CreateObject("scripting.dictionary")
    69. 'Für jeden Berater
    70. For r = 5 To .Cells(Rows.Count, 1).End(xlUp).Row
    71. 'Wenn Projektnummer in der Zeile des Beraters auftaucht, dann Beratername zu Dictionary hinzufügen
    72. For i = 8 To .Columns.Count Step 2 'dieses i läuft scheinbar bis über 4965, obwohl der gleiche Code oben korrekt funktioniert
    73. If i > 150 Then Exit For
    74. If .Cells(r, i).Text = strKey Then
    75. berater.Item(.Cells(r, 1).Text) = ""
    77. Debug.Print "Berater " & .Cells(r, 1).Text & " in Projekt " & strKey
    79. 'Raus aus der Schleife, wir brauchen nicht weiter zu suchen - Berater war dabei
    80. Exit For
    81. End If
    82. Next i
    83. Next r
    85. 'Berater-Liste in Dictionary speichern
    86. oDict_Berater.Key(strKey) = berater
    88. Next
    90. End With
    92. 'TODO: Berater-Liste in Spalten einfügen
    94. With ActiveWorkbook.Worksheets("Projekte_neu")
    96. Dim spalte As Integer
    97. spalte = 5
    99. 'Projektnummern-Spalte durchgehen und Projekt finden, dann Berater-Spalten füllen
    100. Debug.Print "Gebe Beraterlisten aus..."
    102. For Each strProjektnummer In oDict_Berater.Keys
    103. Debug.Print "Key: " & strProjektnummer
    104. For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
    105. If r > 150 Then Exit For 'Vorerst nach 150 Zeilen abbrechen (Trotzdem: Warum erkennt er die letzte Zeile nicht selbst?)
    106. If .Cells(r, 1).Text = strProjektnummer Then 'Fehler: Ungültige Anzahl an Argumenten oder ungültige Zuweisung
    107. For Each strBerater In oDict_Berater.Item(strProjektnummer)
    108. .Cells(r, spalte).Text = strBerater
    109. spalte = spalte + 1
    110. Next
    111. 'Beginn Berater-Spalten zurücksetzen
    112. spalte = 5
    113. End If
    114. Next
    115. Next
    117. End With
    119. End Sub


    Kannst du / könnt ihr mir hier weiterhelfen?

    Vielen Dank vorab!

Facebook
Telefonspende