AW: Aus 2 Tab.-blättern identische Datensätze finden
19.12.2010 20:28:16
Josef
Hallo Mike,
lösche die Leerzeilen unter den Überschriften (haben in einer Liste nichts verloren!) und teste den folgenden Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub compare()
Dim objSh1 As Worksheet, objSh2 As Worksheet, objShMatch As Worksheet, objShNoMatch
Dim rng As Range
On Error GoTo ErrExit
Application.ScreenUpdating = False
Set objSh1 = Sheets("daten1")
Set objSh2 = Sheets("daten2")
Set objShMatch = Sheets("identische")
Set objShNoMatch = Sheets("nicht-identische")
objShMatch.UsedRange.Clear
objShNoMatch.UsedRange.Clear
With objSh1
.Columns(11).Insert
.Cells(1, 11) = "X"
.Cells(2, 11).FormulaArray = "=ISNUMBER(MATCH(A2&E2,'" & objSh2.Name & "'!A:A&'" & objSh2.Name & _
"'!E:E,0))"
.Range(.Cells(2, 11), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 11)).FillDown
.Columns(11).Value = .Columns(11).Value
End With
With objSh2
.Columns(11).Insert
.Cells(1, 11) = "X"
.Cells(2, 11).FormulaArray = "=ISNUMBER(MATCH(A2&E2,'" & objSh1.Name & "'!A:A&'" & objSh1.Name & _
"'!E:E,0))"
.Range(.Cells(2, 11), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 11)).FillDown
.Columns(11).Value = .Columns(11).Value
End With
With objSh1
If .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=11, Criteria1:="TRUE", Operator:=xlAnd
On Error Resume Next
Set rng = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.Copy objShMatch.Range("A1")
.Range("A1").AutoFilter Field:=11, Criteria1:="FALSE", Operator:=xlAnd
On Error Resume Next
Set rng = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.Copy objShNoMatch.Range("A1")
.Range("A1").AutoFilter
.Columns(11).Delete
End With
With objSh2
If .AutoFilterMode Then .Range("A1").AutoFilter
.Range("A1").AutoFilter Field:=11, Criteria1:="FALSE", Operator:=xlAnd
On Error Resume Next
With .Range("A1").CurrentRegion
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
End With
On Error GoTo 0
If Not rng Is Nothing Then rng.Copy objShNoMatch.Cells(objShNoMatch.Cells(Rows.Count, _
1).End(xlUp).Row + 1, 1)
.Range("A1").AutoFilter
.Columns(11).Delete
End With
objShMatch.Columns(11).Delete
objShNoMatch.Columns(11).Delete
ErrExit:
Application.ScreenUpdating = True
Set objSh1 = Nothing
Set objSh2 = Nothing
Set objShMatch = Nothing
Set objShNoMatch = Nothing
Set rng = Nothing
End Sub
Gruß Sepp
