Doppelte Inhalte suchen und kopieren

HI,
ich habe eine Tabelle mit verschiedenen Einträgen in Spalte B. Diese habe ich seither farblich markiert (Spalte B) :
Dim lngRow As Long
lngRow = Cells(Rows.Count, "B").End(xlUp).Row
Dim I As Integer, xx As Integer
Dim szCompare As String
For I = 5 To lngRow
szCompare = Left(Sheets("Liste").Cells(I, 2).Value, 5) & "*"
If WorksheetFunction.CountIf(Sheets("Liste").Cells(1, 2).Resize(lngRow), szCompare) > 1 Then
Sheets("Liste").Cells(I, 2).Font.ColorIndex = 3
End If
Next I
Nun wollte ich , gleich nach dem farblich markieren, alle Datensätze mit doppeltem oder mehrfach vorkommenden Inhalt auch in ein seperates Datenblatt kopieren, (Originale NICHT löschen) und zwar so:
- wenn doppelte erkannt werden, soll ein neues Blatt "Doppelte" angelegt werden.
- darin soll ab Zeile 5 die komplette Zeile der Doppelten oder mehrfach vorkommenden DS reinkopiert werden.
- Falls schon ein Blatt "Doppelte" existiert, soll dort ab der nächsten freien Zeile die daten reinkopiert werden. ( also, wenn zB Zeile 5 - 20 schon belegt, dann ab Zeile 21 wieter machen)
habe leider keine Idee oder Grips, wie man sowas macht oder den Obigen Code erweitern muss.
Über jegliche Hilfe wäre ich sehr dankbar.
Gruss
Joachim

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
versuche es mal mit diesem Code, dieser verwendet Formel in einer Hilfsspalte,
diese ist die letzte auf dem Tabellenblatt und wird am Ende wieder gelöscht.
Es werden alle doppelten Einträge die in Spalte B gefunden werden nach Tabelle Doppelt übertragen, ist diese nicht vorhanden, wird sie angelegt.

Sub DoppelFinden()
Dim Bereich As Range
Dim myTab As Worksheet, i As Integer
Dim LRow As Long
    
With Application
 .ScreenUpdating = False
 .EnableEvents = False
       
       With ThisWorkbook.Sheets("Tabelle1") 'Tabellennamen anpassen 
         
             LRow = .Cells(.Rows.Count, 2).End(xlUp).Row
             Set Bereich = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
             Set Bereich = Bereich.Offset(0, .Columns.Count - Bereich.Column)
             Bereich.FormulaR1C1 = "=IF(COUNTIF(RC2:R" & LRow & "C2,RC2)>1,0,"""")"
        If Application.WorksheetFunction.CountIf(.Columns(.Columns.Count), 0) > 0 Then
                
                For i = 1 To ThisWorkbook.Worksheets.Count
                 If ThisWorkbook.Worksheets(i).Name = "Doppelt" Then
                  Set myTab = ThisWorkbook.Worksheets(i)
                  Exit For
                 End If
                Next i
    
                If myTab Is Nothing Then
                 Set myTab = Worksheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                 myTab.Name = "Doppelt"
                End If
             
             
             Set Bereich = Bereich.SpecialCells(xlCellTypeFormulas, 1)
             LRow = 0
                    With myTab
                      On Error Resume Next
                        LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False).Row
                        If .Cells.Find("*", , xlFormulas, 2, 1, 2, False, False).Row > LRow Then
                         LRow = .Cells.Find("*", , xlFormulas, 2, 1, 2, False, False).Row
                        End If
                      On Error GoTo 0
                          LRow = LRow + 1
                          Bereich.EntireRow.Copy .Cells(LRow, 1)
                          .Columns(.Columns.Count).Delete
                    End With 'myTab 
         
         
         End If
            .Columns(.Columns.Count).Delete
        End With '.Sheets("Tabelle1") 

 .ScreenUpdating = True
 .EnableEvents = True
End With 'Application 

End Sub

Gruß Tino

Sub DoppelFinden() Dim Bereich As Range Dim myTab As Worksheet, i As Integer Dim LRow As Long With Application .ScreenUpdating = False .EnableEvents = False With ThisWorkbook.Sheets("Tabelle1") 'Tabellennamen anpassen LRow = .Cells(.Rows.Count, 2).End(xlUp).Row Set Bereich = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)) Set Bereich = Bereich.Offset(0, .Columns.Count - Bereich.Column) Bereich.FormulaR1C1 = _ "=IF(OR(COUNTIF(RC2:R" & LRow & "C2,RC2)>1,COUNTIF(R1C2:R" & LRow & "C2,RC2)>1),0,"""")" If Application.WorksheetFunction.CountIf(.Columns(.Columns.Count), 0) > 0 Then For i = 1 To ThisWorkbook.Worksheets.Count If ThisWorkbook.Worksheets(i).Name = "Doppelt" Then Set myTab = ThisWorkbook.Worksheets(i) Exit For End If Next i If myTab Is Nothing Then Set myTab = Worksheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) myTab.Name = "Doppelt" End If Set Bereich = Bereich.SpecialCells(xlCellTypeFormulas, 1) LRow = 0 With myTab On Error Resume Next LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False).Row If .Cells.Find("*", , xlFormulas, 2, 1, 2, False, False).Row > LRow Then LRow = .Cells.Find("*", , xlFormulas, 2, 1, 2, False, False).Row End If On Error GoTo 0 LRow = LRow + 1 Bereich.EntireRow.Copy .Cells(LRow, 1) .Columns(.Columns.Count).Delete End With 'myTab End If .Columns(.Columns.Count).Delete End With '.Sheets("Tabelle1") .ScreenUpdating = True .EnableEvents = True End With 'Application End Sub

Beliebteste Forumthreads (12 Monate)

Doppelte Inhalte suchen und kopieren

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelte Inhalte suchen und kopieren

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

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread