Thema Datum  Von Nutzer Rating
Antwort
Rot Reihen automatisch entfernen
14.11.2022 09:48:53 Gast45877
NotSolved

Ansicht des Beitrags:
Von:
Gast45877
Datum:
14.11.2022 09:48:53
Views:
96
Rating: Antwort:
  Ja
Thema:
Reihen automatisch entfernen

Hallo zusammen smiley

Ich bräuchte eure Hilfe bei folgendem Problem. Der Code (s. unten) vergleicht die Zeilen aus Sheet(1), insbesondere Spalte A, E und H. Sind diese gleich werden die Duplikate in Sheet(2) kopiert. (Anzumerken ist, dass ich diesen Code nicht selber geschrieben habe, sondern ein Internet User Names Uwe. Danke Uwe). Soweit so gut. Da ich als VBA Laie leider noch nicht auf deisem Niveau coden kann stellt sich mir jetzt die Frage, wie ich die kopierten Reihen in denen sich Duplikate befinden, nachdem Sie ins Sheet(2) kopiert wurden, automatisch aus Sheet(1) entfernen kann. 


Sub Duplicates()

    Dim ws1 As Worksheet, ws2 As Worksheet, cell As Range, dic As Object
    
    Set ws1 = Sheets(2)
    Set ws2 = Sheets(3)
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With ws1
        'Überschriften kopieren
        .Range("1:1").Copy ws2.Range("1:1")
        'jede Zeile der Tabelle durchlaufen
        For Each cell In .Range("A2:A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row)
            'Vergleichstring für Dictionary
            strCompare = cell.Offset(0, 0).Value & "|" & cell.Offset(0, 4).Value & "|" & cell.Offset(0, 7).Value
            
            If Not dic.Exists(strCompare) Then
                'existiert für die Zeile kein Eintrag füge ihn hinzu
                dic.Add strCompare, cell.Address
            Else
                If dic.Item(strCompare) <> "" Then
                    .Range(dic.Item(strCompare)).EntireRow.Copy ws2.Range("A" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                    dic.Item(strCompare) = ""
                   
                End If
                ' Eintrag existiert bereits kopiere Zeile in Zielsheet
                cell.EntireRow.Copy ws2.Range("A" & ws2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
            End If
        Next

    End With
    
End Sub


 

Danke für eure Unterstützung! 

 

LG 
 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Reihen automatisch entfernen
14.11.2022 09:48:53 Gast45877
NotSolved