ich habe da ein kleines Problem: ich möchte gerne Duplikate in den Spalten A und B suchen und die betreffenden Zeilen dann in die Tabelle 2 verschieben
Kann mir da jemand helfen?
Silke
Sub dup()
Dim i
With Worksheets("Tabelle1")
For i = .Range("A65000").End(xlUp).Row To 1 Step -1
If Cells(i, 1) = Cells(i, 2) Then
Rows(i & ":" & i).Copy Destination:=Worksheets("Tabelle2").Range(i & ":" & i)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlUp
End If
Next
End With
Worksheets("Tabelle2").UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
Die Zeile 1 in Tabelle2 muss vorher (!) eine Überschrift haben, sonst produziert die Leerzeilen-Löschung einen Fehler! Könnte man noch anders lösen, aber da ich deine Anforderungen nicht kenne...
Rückmeldung wäre nett.
gruß
David
Option Explicit
Sub Doppelte_Nach_Tab2()
Dim Bereich 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)
'Ziel leer machen
shZiel.Range("A2", shZiel.Cells(shZiel.Rows.Count, shZiel.Columns.Count)).Value = ""
'Hilfsformel schreiben
Bereich.FormulaR1C1 = _
"=IF(OR(COUNTIF(R2C1:RC1,RC1)>1,COUNTIF(R2C2:RC2,RC2)>1),0,"""")"
'prüfen ob 0 als Ergebnis vorhanden
If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
'Zeilen mit Ergebnis 0 kopieren
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Copy shZiel.Range("A2")
End If
'Hilfsspalte löschen
shQuelle.Columns(shQuelle.Columns.Count).Delete
End If
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino
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()"
'Ziel leer machen
shZiel.Range("A2", shZiel.Cells(shZiel.Rows.Count, shZiel.Columns.Count)).Value = ""
'Hilfsformel schreiben
Bereich.FormulaR1C1 = _
"=IF(OR(COUNTIF(R2C1:RC1,RC1)>1,COUNTIF(R2C2:RC2,RC2)>1),0,"""")"
'prüfen ob 0 als Ergebnis vorhanden
If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
'sortieren nach 0
shQuelle.UsedRange.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
shQuelle.UsedRange.Sort SortBereich(1, 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
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