AW: Spalten vergleichen und Zeilen verschieben
08.05.2009 09:28:45
Tino
Hallo,
oben hast Du geschrieben.
"...ich möchte gerne Duplikate in den Spalten A und B suchen und die betreffenden Zeilen dann in die Tabelle 2 verschieben..."
und jetzt schreibst Du
"...so werden ein paar garnicht kopiert, obwohl sie nicht doppelt sind..."
Was willst Du jetzt, die doppelten oder die nicht doppelten?
Dieser Code kopiert jetzt alle die mehr als einmal in Spalte A bzw. in Spalte B vorkommen.
Sub Doppelte_Nach_Tab2()
Dim Bereich As Range, SortBereich As Range
Dim shQuelle As Worksheet, shZiel As Worksheet
Dim iCalc As Integer
Dim LRow As Long
Set shQuelle = Sheets("Tabelle1") 'Tabellennamen Quelle anpassen
Set shZiel = Sheets("Tabelle2") 'Tabellennamen Ziel anpassen
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
On Error Resume Next 'letze Zeile in Spalte A u. B Suchen
LRow = shQuelle.Range("A:B").Find("*", , xlValues, 2, 1, 2, False, False).Row
LRow = .Max(LRow, shQuelle.Range("A:B").Find("*", , xlFormulas, 2, 1, 2).Row)
On Error GoTo 0
If LRow > 1 Then 'Prüfen ob der Bereich nicht in der Überschrift liegt
Set Bereich = shQuelle.Range("A2:A" & LRow)
Set Bereich = Bereich.Offset(0, shQuelle.Columns.Count - Bereich.Column)
Set SortBereich = Bereich.Offset(0, -1)
'Hilsspalte zum Sortieren
SortBereich.FormulaR1C1 = "=ROW()"
Set SortBereich = shQuelle.Range("A1", Cells(LRow, shQuelle.Columns.Count))
'Ziel leer machen
shZiel.Range("A2", shZiel.Cells(shZiel.Rows.Count, shZiel.Columns.Count)).Value = ""
'Hilfsformel schreiben
Bereich.FormulaR1C1 = _
"=IF(OR(COUNTIF(R2C1:R" & LRow & "C1,RC1)>1,COUNTIF(R2C2:R" & LRow & "C2,RC2)>1),0,"""")"
'prüfen ob 0 als Ergebnis vorhanden
If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
'sortieren nach 0
SortBereich.Sort Bereich(1, 1), xlAscending, , , , , , xlYes
'Zeilen mit Ergebnis 0 kopieren
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Copy shZiel.Range("A2")
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
'zurücksortieren
SortBereich.Sort SortBereich(2, SortBereich.Columns.Count - 1), xlAscending, , , , , , xlYes
End If
'Hilfsspalte löschen
shQuelle.Columns(shQuelle.Columns.Count).Delete
shQuelle.Columns(shQuelle.Columns.Count - 1).Delete
End If
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino