Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Doppelte Inhalte suchen und kopieren

Doppelte Inhalte suchen und kopieren
08.02.2009 13:07:42
Joachim
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

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

Betreff
Datum
Anwender
Anzeige
habe noch was vergessen..
08.02.2009 13:25:00
Joachim
..
wenn in B mal 2 oder mehrere Zellen ohne Inhalt sind, sollen die nicht als GLEICHER INHALT bewertet werden. nur Zellen mit inhalt berücksichtigen.
Gruss
Joachim
keiner eine Idee ? oT
08.02.2009 20:45:42
Joachim
habe eine Idee
09.02.2009 09:49:38
Tino
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

Anzeige
AW: habe eine Idee
09.02.2009 20:20:00
Joachim
Hallo Tino,
Danke, das funktioniert. Kannst Du den Code vielleicht noch so ändern dass der Erste Datensatz auch mit kopiert wird. Also, wenn zB. ein String zwei mal vorkommt, dass dann beide Zeilen kopiet werden, nicht nur der zweite ? Ist das Möglich ?
Ansonsten Vielen Dank, würde zur Not auch so reichen.
Joachim
so müsste es funktionieren...
09.02.2009 23:24:00
Tino
Hallo,
, habe nur die Formel etwas erweitert.
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


Gruß Tino

Anzeige
ja, funktioniert, danke oT
10.02.2009 13:45:06
Joachim
AW: ja, funktioniert, danke oT
10.02.2009 14:34:21
zu
zu

315 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige