hi all ^^
makrokenntnisse vorrausgesetz
spalten a b c sind jeweils in tab1 wie tab2 gefuellt
unterschiede werden farblich hinterlegt
Option Explicit
Sub vergleich()
Dim w1x As Integer, w2x As Integer, w3x As Integer, zaehler1 As Integer
Dim w1y As Long, w2y As Long, w3y As Long, zaehler0 As Long
Dim suche1, suche2 As Range
w1x = Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w1y = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
w2x = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w2y = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
If w1x > w2x Then
w3x = w1x
Else
w3x = w2x
End If
If w1y > w2y Then
w3y = w1y
Else
w3y = w2y
End If
ReDim excel1(w3y, w3x) As Variant
ReDim excel2(w3y, w3x) As Variant
Sheets(2).Select
excel2() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(1).Select
excel1() = Range(Cells(1, 1), Cells(w3y, w3x))
For zaehler0 = 2 To w3y
Set suche1 = Sheets(2).Range("A1:A" & w3y).Find(excel1(zaehler0, 1), Lookat:=xlWhole)
Set suche2 = Sheets(1).Range("A1:A" & w3y).Find(excel2(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel1(zaehler0, zaehler1) <> "" And excel1(zaehler0, zaehler1) <> excel2(suche1.Row, zaehler1) Then
Sheets(1).Cells(zaehler0, zaehler1).Interior.ColorIndex = 3
End If
Next zaehler1
Else
Sheets(1).Range(Sheets(1).Cells(zaehler0, 1), Sheets(1).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
If Not suche2 Is Nothing Then
For zaehler1 = 2 To w3x
If excel2(zaehler0, zaehler1) <> "" And excel2(zaehler0, zaehler1) <> excel1(suche2.Row, zaehler1) Then
Sheets(2).Cells(zaehler0, zaehler1).Interior.ColorIndex = 3
End If
Next zaehler1
Else
Sheets(2).Range(Sheets(2).Cells(zaehler0, 1), Sheets(2).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
End Sub
zweites beispiel
fasst die daten von tab1 wie tab2 zusammen mit aisschluss von leerspalten
Option Explicit
Sub vergleich()
Call EventsOff
Dim zaehler0 As Long, zaehler1 As Long, spaltea1 As Long, zeile As Long
If Sheets(1).Range("A" & Rows.Count).End(xlUp).Row > Sheets(2).Range("A" & Rows.Count).End(xlUp).Row Then
spaltea1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Else
spaltea1 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
End If
ReDim sh1(spaltea1, 1) As Variant
ReDim sh2(spaltea1, 1) As Variant
Sheets(2).Select
sh2() = Range(Cells(1, 1), Cells(spaltea1, 1))
Sheets(1).Select
sh1() = Range(Cells(1, 1), Cells(spaltea1, 1))
For zaehler0 = 2 To spaltea1
For zaehler1 = 2 To spaltea1
If sh1(zaehler0, 1) = sh2(zaehler1, 1) Then
zeile = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(3).Range("A" & zeile & ":D" & zeile) = Array(Sheets(1).Range("A" & zaehler0), Sheets(1).Range("C" & zaehler0), Sheets(1).Range("H" & zaehler0), Sheets(1).Range("K" & zaehler0))
Sheets(3).Range("E" & zeile & ":G" & zeile) = Array(Sheets(2).Range("B" & zaehler1), Sheets(2).Range("G" & zaehler1), Sheets(2).Range("L" & zaehler1))
End If
Next zaehler1
Next zaehler0
Call EventsOn
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
dritte beispiel
ein abgleich von tab2 zu tab1 spalten a b gefuellt
Option Explicit
Sub Vergleich()
Dim Lzeile As Long, Qlzeile As Long
Dim Zaehler1 As Long, Zaehler2 As Long
Lzeile = Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Qlzeile = Worksheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
ReDim ArrQ(Qlzeile, 2) As Variant
ReDim ArrZ(Lzeile, 2) As Variant
Worksheets(2).Activate
ArrQ() = Range("A1:B" & Qlzeile)
Worksheets(1).Activate
ArrZ() = Range("A1:B" & Lzeile)
For Zaehler1 = 2 To Lzeile
For Zaehler2 = 2 To Qlzeile
If ArrZ(Zaehler1, 1) = ArrQ(Zaehler2, 1) Then
ArrZ(Zaehler1, 2) = ArrQ(Zaehler2, 2)
Exit For
End If
Next Zaehler2
Next Zaehler1
Worksheets(1).Range("A1:B" & Lzeile) = ArrZ()
End Sub
gruss nighty
@admin
das editieren geht nun immer noch nicht,curser ohne bewegung,das nervt seit monaten ^^
