Microsoft Office Forum [ www.Office-Fragen.de ] >> READONLY <<

Microsoft Office 2003-2019 => Excel => Thema gestartet von: FlorianF am Juli 27, 2017, 08:58:59 Vormittag

Titel: Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am Juli 27, 2017, 08:58:59 Vormittag
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
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: maninweb am Juli 27, 2017, 09:58:59 Vormittag
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ß
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am Juli 31, 2017, 13:51:59 Nachmittag
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?
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: maninweb am Juli 31, 2017, 20:06:29 Nachmittag
Hallo,

lade am besten mal eine anonymisierte Beispieldatei hier hoch.

Gruß
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am August 02, 2017, 08:29:14 Vormittag
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
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: maninweb am August 02, 2017, 09:23:39 Vormittag
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ß
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am August 02, 2017, 10:28:38 Vormittag
Jetzt bringt er mir ein Fehler:

Zitat
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?

Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: gmg-cc am August 02, 2017, 11:08:57 Vormittag
Moin,
das If in Zeile 49
Code: [Auswählen]
If MsgBox("Die folgenden " & intFehlenderBuchungstextZaehler & ...wird nicht (richtig) abgeschlossen.
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am August 02, 2017, 11:22:34 Vormittag
Seh ich irgendetwas nicht? In welcher Zeile müsste denn noch ein End if stehen?
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: maninweb am August 02, 2017, 12:01:55 Nachmittag
Hallo,

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

Gruß
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am August 02, 2017, 12:49:54 Nachmittag
Ok läuft nun durch danke!

Nun noch zwei Fragen:

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
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: FlorianF am August 04, 2017, 10:54:56 Vormittag
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? :)
Titel: Antw:Office 2016 Duplikat aus Array löschen
Beitrag von: maninweb am August 04, 2017, 16:46:17 Nachmittag
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ß