Office 2016 Duplikat aus Array löschen

[FlorianF]

Hi Leute,

ich muss aus einem Array doppelte Inhalte löschen, leider gelingt mir das jedoch nicht. Ich habe schon einige im Net gefundenen Codeschnipsel getestet, aber kann das wohl nicht auf meine Situation korrekt übertragen.

Damit befülle ich das Array:

Code: [Auswählen]

For Each rngZelle In rngSpalte
       
        strBuchungstext = rngZelle.Value
       
        On Error Resume Next
        If IsError(tblKontenzuordnung.Range("A:A").Find(strBuchungstext).Offset(0, 1).Value) Then
            intFehlenderBuchungstextZaehler = intFehlenderBuchungstextZaehler + 1
            strAryFehlenderBuchungstext(intFehlenderBuchungstextZaehler) = rngZelle.Value
            On Error GoTo 0
        End If

Next rngZelle
Damit lese ich das Array aus:

Code: [Auswählen]

For i = 1 To intFehlenderBuchungstextZaehler
            strAuflistungBuchungstexte = strAuflistungBuchungstexte & strAryFehlenderBuchungstext(i) & vbCrLf
Next i
Dazwischen sollen nun die Duplikat im Array gelöscht werden.

Kann mir jemand sagen wie das klappt?

Danke auch schon mal!

Beste Grüße
Flo

[maninweb]

Hallo,

anbei ein Beispielcode und eine Beispieldatei, wie Du Duplikate entfernen kannst...

Code: Visual Basic

1.   Public Sub DuplikateEntfernen()
2.    
3.     Dim d As Collection
4.     Dim n As Long
5.     Dim p As Long
6.     Dim t As String
7.     Dim u As Variant
8.     Dim v As Variant
9.    
10. '   Fehler abschalten...
11.    
12.     On Error Resume Next
13.    
14. '   Array einlesen...
15.    
16.     u = ThisWorkbook.Worksheets("Tabelle1").Range("A1:A32").Value
17.    
18. '   Redim...
19.    
20.     ReDim v(LBound(u, 1) To UBound(u, 1), 1 To 1)
21.    
22. '   Collection...
23.    
24.     Set d = New Collection
25.    
26. '   Index...
27.    
28.     p = LBound(u, 1)
29.    
30. '   Durchlauf und Duplikate entfernen
31.    
32.     For n = LBound(u, 1) To UBound(u, 1)
33.      
34.       t = ""
35.       t = d("Key=" & u(n, 1))
36.      
37. '     Check...
38.      
39.       If Len(t) < 1 Then
40.        
41. '       Kopie...
42.        
43.         v(p, 1) = u(n, 1)
44.        
45. '       Index...
46.        
47.         p = p + 1
48.        
49. '       Collection...
50.        
51.         d.Add CStr(n), "Key=" & u(n, 1)
52.        
53.       End If
54.      
55.     Next
56.    
57. '   Collection...
58.    
59.     Set d = Nothing
60.    
61. '   Ausgabe...
62.    
63.     ThisWorkbook.Worksheets("Tabelle1").Range("B1:B32").Value = v
64.    
65.   End Sub
66.  

Gruß

[FlorianF]

Danke!

Ich versuche das ganze nun mit der Übergabe meines Arrays und dann wieder dem Zurücklesen in das Array zu nutzen. Aber bekomme ich nicht hin. Wie kann ich also mein ArrayMitDuplikat an die Sub übergeben und diese (oder auch ein zweites) ArrayOhneDuplikat wieder zubekommen um damit dann weiterzuarbeiten?

[maninweb]

Hallo,

lade am besten mal eine anonymisierte Beispieldatei hier hoch.

Gruß

[FlorianF]

Das ist eine "riesen" Datei mit zig Modulen und ewig langem Code. Soll ich das wirklich alles hier hochladen? Alternativ habe ich hier nochmal die relevanten Stellen meines Codes beigefügt:

Code: [Auswählen]

Option Explicit

Sub PruefenBuchungstexte()
   
    Dim rngDaten As Range, rngSpalte As Range, rngZelle As Range
    Dim strBuchungstext As String, strKontoNeu As String
    Dim strAuflistungBuchungstexte As String
    Dim strAryFehlenderBuchungstext(10000) As String
    Dim intFehlenderBuchungstextZaehler As Integer
    Dim intLetzteZeile As Integer, i As Integer
   
    Set rngSpalte = tblBuchungen.Range("F2:F" & tblBuchungen.UsedRange.Rows.Count)
   
    For Each rngZelle In rngSpalte
       
        strBuchungstext = rngZelle.Value
       
        On Error Resume Next
        If IsError(tblKontenzuordnung.Range("A:A").Find(strBuchungstext).Offset(0, 1).Value) Then
            intFehlenderBuchungstextZaehler = intFehlenderBuchungstextZaehler + 1
            strAryFehlenderBuchungstext(intFehlenderBuchungstextZaehler) = rngZelle.Value
            On Error GoTo 0
        End If
   
    Next rngZelle
   
    '#####################
    'Bis hier ist das Array mit den Duplikaten gefüllt. Diese sollen vor dem nächsten Schritt innerhalb des Arrays gelöscht werde
    '#####################
   
    If intFehlenderBuchungstextZaehler > 0 Then
       
        For i = 1 To intFehlenderBuchungstextZaehler
            strAuflistungBuchungstexte = strAuflistungBuchungstexte & strAryFehlenderBuchungstext(i) & vbCrLf
        Next i
       
        If MsgBox("Die folgenden " & intFehlenderBuchungstextZaehler & " Buchungstexte fehlen in der Kontenzuordnung:" & vbCrLf & vbCrLf & _
            strAuflistungBuchungstexte & vbCrLf & _
            "Sollen die Buchungstexte in die Kontenzuordnung eingetragen werden?", _
            vbExclamation + vbYesNo, p_cstrAppName & " " & p_cstrAppVersion) = vbYes Then
               
                intLetzteZeile = tblKontenzuordnung.UsedRange.Rows.Count
               
                For i = 1 To intFehlenderBuchungstextZaehler
                    tblKontenzuordnung.Cells(intLetzteZeile + i, 1).Value = strAryFehlenderBuchungstext(i)
                Next i
               
                MsgBox "Die Buchungstexte wurden in der Kontenzuordnung eingetragen. Bitte erfassen Sie die zugehörigen Buchungskonten.", vbInformation, p_cstrAppName & " " & p_cstrAppVersion
               
                tblKontenzuordnung.Activate
               
        End If
       
    End If
   
End Sub



[maninweb]

Hallo,

versuche es mal mit folgendem Code, wo die Duplikate erst gar nicht eingelesen werden dürften.
Der Code ist ungetestet. Ausserdem kannst Du ruhigen Gewissens Long statt Integer verwenden.

Code: Visual Basic

1. Option Explicit
2.  
3. Sub PruefenBuchungstexte()
4.    
5.     Dim rngDaten As Range, rngSpalte As Range, rngZelle As Range
6.     Dim strBuchungstext As String, strKontoNeu As String
7.     Dim strAuflistungBuchungstexte As String
8.     Dim strAryFehlenderBuchungstext(10000) As String
9.     Dim intFehlenderBuchungstextZaehler As Long
10.     Dim intLetzteZeile As Long, i As Long
11.    
12.     Dim strTemp As String
13.     Dim objData As Collection
14.    
15.     Set rngSpalte = tblBuchungen.Range("F2:F" & tblBuchungen.UsedRange.Rows.Count)
16.     Set objData = New Collection
17.        
18.     For Each rngZelle In rngSpalte
19.        
20.         strBuchungstext = rngZelle.Value
21.        
22.         On Error Resume Next
23.        
24.         If IsError(tblKontenzuordnung.Range("A:A").Find(strBuchungstext).Offset(0, 1).Value) Then
25.            
26.             strTemp = ""
27.             strTemp = objData("Key=" & rngZelle.Value)
28.            
29.             If Len(strTemp) < 1 Then
30.            
31.             intFehlenderBuchungstextZaehler = intFehlenderBuchungstextZaehler + 1
32.             strAryFehlenderBuchungstext(intFehlenderBuchungstextZaehler) = rngZelle.Value
33.             objData.Add CStr(intFehlenderBuchungstextZaehler), "Key=" & rngZelle.Value
34.            
35.             On Error GoTo 0
36.            
37.         End If
38.    
39.     Next rngZelle
40.    
41.     Set objData = Nothing
42.    
43.     If intFehlenderBuchungstextZaehler > 0 Then
44.        
45.         For i = 1 To intFehlenderBuchungstextZaehler
46.             strAuflistungBuchungstexte = strAuflistungBuchungstexte & strAryFehlenderBuchungstext(i) & vbCrLf
47.         Next i
48.        
49.         If MsgBox("Die folgenden " & intFehlenderBuchungstextZaehler & " Buchungstexte fehlen in der Kontenzuordnung:" & vbCrLf & vbCrLf & _
50.             strAuflistungBuchungstexte & vbCrLf & _
51.             "Sollen die Buchungstexte in die Kontenzuordnung eingetragen werden?", _
52.             vbExclamation + vbYesNo, p_cstrAppName & " " & p_cstrAppVersion) = vbYes Then
53.                
54.                 intLetzteZeile = tblKontenzuordnung.UsedRange.Rows.Count
55.                
56.                 For i = 1 To intFehlenderBuchungstextZaehler
57.                     tblKontenzuordnung.Cells(intLetzteZeile + i, 1).Value = strAryFehlenderBuchungstext(i)
58.                 Next i
59.                
60.                 MsgBox "Die Buchungstexte wurden in der Kontenzuordnung eingetragen. Bitte erfassen Sie die zugehörigen Buchungskonten.", vbInformation, p_cstrAppName & " " & p_cstrAppVersion
61.                
62.                 tblKontenzuordnung.Activate
63.                
64.         End If
65.        
66.     End If
67.    
68. End Sub

Gruß

[FlorianF]

Jetzt bringt er mir ein Fehler:

Next ohne For

auf dem ersten Next, in deinem Code also Zeile 39. Aber da ist das alles drin oder nicht?

Vielleicht noch etwas, ich denke das funktioniert mit dem Code bis jetzt noch nicht, aber konnte es aufgrund des benannten Fehler noch nicht testen. Die Schleife in den Zeile 45-47 fühlt ja den String für die MsgBox. Hier muss ich ja auch die Daten ohne Duplikate auswerten, kommen die dort auch an?

[gmg-cc]

Moin,
das If in Zeile 49

Code: [Auswählen]

If MsgBox("Die folgenden " & intFehlenderBuchungstextZaehler & ...wird nicht (richtig) abgeschlossen.

[FlorianF]

Seh ich irgendetwas nicht? In welcher Zeile müsste denn noch ein End if stehen?

[maninweb]

Hallo,

sorry, habe ein End-If vergessen. Nach der Zeile On Error GoTo 0 muss noch ein End If hin

Gruß

[FlorianF]

Ok läuft nun durch danke!

Nun noch zwei Fragen:

• Wie kann ich den eingefügten Code auslagern, sodass ich das Prozedere an mehreren Stellen verwenden kann?
• Wie gehe ich mit einem zweidimensionalen Array um? Hier mal ein Beispiel.

Code: [Auswählen]

Sub PartyCodesPruefen()

    Dim rngDaten As Range, rngSpalte As Range, rngZelle As Range
    Dim strPartyCode As String, strKontoNeu As String
    Dim strAuflistungPartyCodes As String
    Dim strAryFehlenderPartyCode(10000, 1) As String
    Dim intFehlenderPartyCodeZaehler As Integer
    Dim intLetzteZeile As Integer, i As Integer
   
    p_intFehlerPartyCodes = 0
   
    If tblBuchungen.UsedRange.Rows.Count = 1 Then   
        Exit Sub
    Else
        Set rngSpalte = tblBuchungen.Range("C2:C" & tblBuchungen.UsedRange.Rows.Count)
    End If
   
    For Each rngZelle In rngSpalte

        strPartyCode = rngZelle.Value
       
        On Error Resume Next
        If IsError(tblKreditorenzuordnung.Range("A:A").Find(strPartyCode).Offset(0, 1).Value) Then
            intFehlenderPartyCodeZaehler = intFehlenderPartyCodeZaehler + 1
            strAryFehlenderPartyCode(intFehlenderPartyCodeZaehler, 0) = rngZelle.Value
            strAryFehlenderPartyCode(intFehlenderPartyCodeZaehler, 1) = rngZelle.Offset(0, 1).Value
            On Error GoTo 0     'Wenn Fehler erzeugt wieder normal fortfahren
        End If
   
    Next rngZelle
   
    If intFehlenderPartyCodeZaehler > 0 Then

        For i = 1 To intFehlenderPartyCodeZaehler
            strAuflistungPartyCodes = strAuflistungPartyCodes & strAryFehlenderPartyCode(i, 0) & _
                vbTab & vbTab & strAryFehlenderPartyCode(i, 1) & vbCrLf
        Next i
       
        If MsgBox("Die folgenden " & intFehlenderPartyCodeZaehler & " Party Codes fehlen in der Kreditorenzuordnung:" & vbCrLf & vbCrLf & _
            strAuflistungPartyCodes & vbCrLf & _
            "Sollen die PartyCodes in die Kreditorenzuordnung eingetragen werden?", _
            vbExclamation + vbYesNo, p_cstrAppName & " " & p_cstrAppVersion) = vbYes Then
               
                intLetzteZeile = tblKreditorenzuordnung.UsedRange.Rows.Count
               
                For i = 1 To intFehlenderPartyCodeZaehler
                    tblKreditorenzuordnung.Cells(intLetzteZeile + i, 1).Value = strAryFehlenderPartyCode(i, 0)
                    tblKreditorenzuordnung.Cells(intLetzteZeile + i, 2).Value = strAryFehlenderPartyCode(i, 1)
                Next i
               
                MsgBox "Die PartyCodes wurden in der Kreditorenzuordnung eingetragen. Bitte erfassen Sie die zugehörigen Kreditoren.", vbInformation, p_cstrAppName & " " & p_cstrAppVersion
               
                tblKreditorenzuordnung.Activate
               
        End If
       
        p_intFehlerPartyCodes = 1
   
    Else
        MsgBox "Es sind alle Partycodes in der Kreditorenzuordnung erfasst.", vbInformation, p_cstrAppName & " " & p_cstrAppVersion
    End If
   
End Sub


[FlorianF]

Ich habe den Code-Erweiterung jetzt in eine andere Prozedur übertragen und angepasst. Allerdings erhalte ich hier einen Laufzeitfehler 5 (Ungültiger Prozeduraufruf oder ungültiges Argument) in dieser Zeile

Code: [Auswählen]

strTempGegenkonto = objDaten("Key=" & rngZelle.Value)
Hier mal der gesamte Code

Code: [Auswählen]

Sub GegenkontenPruefen()
   
    Dim rngDaten As Range, rngSpalte As Range, rngZelle As Range
    Dim i As Integer
    Dim strAuflistungBuchungstexteOhneGegenkonto As String
    Dim strAryBuchungstextOhneGegenkonto(1000) As String
    Dim intFehlendesgegenkontoZaehler As Integer
    Dim strTempGegenkonto As String
    Dim objDaten As Collection
   
    Set rngSpalte = tblKontenzuordnung.Range("A2:A" & tblKontenzuordnung.UsedRange.Rows.Count)
    Set objDaten = New Collection
   
    For Each rngZelle In rngSpalte
       
        If rngZelle.Offset(0, 1).Value = "" Then
       
            strTempGegenkonto = ""
            strTempGegenkonto = objDaten("Key=" & rngZelle.Value)
           
            If Len(strTempGegenkonto) < 1 Then
               
                intFehlendesgegenkontoZaehler = intFehlendesgegenkontoZaehler + 1
                strAryBuchungstextOhneGegenkonto(intFehlendesgegenkontoZaehler) = rngZelle.Value
               
                objDaten.Add CStr(intFehlendesgegenkontoZaehler), "Key=" & rngZelle.Value
               
                On Error GoTo 0     'Wenn Fehler erzeugt wieder normal fortfahren
            End If
        End If
   
    Next rngZelle
   
    If intFehlendesgegenkontoZaehler > 0 Then
       
        For i = 1 To intFehlendesgegenkontoZaehler
            strAuflistungBuchungstexteOhneGegenkonto = strAuflistungBuchungstexteOhneGegenkonto & strAryBuchungstextOhneGegenkonto(i) & vbCrLf
        Next i
   
        MsgBox "Zu den folgenden Buchungstexten sind keine Gegenkonten erfasst:" & vbCrLf & vbCrLf & _
            strAuflistungBuchungstexteOhneGegenkonto & vbCrLf & _
            "Bitte erfassen Sie die Gegenkonten!", _
            vbExclamation, p_cstrAppName & " " & p_cstrAppVersion
         
        p_intFehlerGegenkonten = 1
   
    Else
        MsgBox "Es ist zu jedem Buchungstext ein Gegenkonten in der Kontenzuordnung erfasst.", vbInformation, p_cstrAppName & " " & p_cstrAppVersion
    End If

End Sub
Kann mir jemand helfen?

[maninweb]

Hallo,

die Fehlermeldung ist korrekt, denn dies ist in meinem Code Absicht. Wenn ein Eintrag nicht in der Collection
vorhanden ist, erhälst Du den Fehler und strTempGegenkonto ist immer noch = "".

Setze somit ein On Error Resume Next nach der Zeile Dim objDaten As Collection.
Und die Zeile On Error GoTo 0 kannste eigentlich wegmachen.

Gruß