Ich habe mehrere Zeilen die ich miteinander vergleichen möchte.
Wenn in zwei Zeilen die Zellen B,C,D übereinstimmen und die Zellen A einen unterschiedlichen Wert haben,
dann sollen diese Zeilen bestehen bleiben.
Zeilen die in den Zellen B,C,D nicht übereinstimmen sollen gelöscht werden
Desweiteren sollen die Zeilen die passen noch so sortiert werden, dass sie als Paare geordnet sind / werden.
Beispie, so soll es dann aussehen:
GFM 1 100 453101 3 20.11.2008 08:13:03 SK 251.263 15.93 17.09 16.95 16.81 16.78 16.67 17.15 16.86 16.78 16.35
GFM 2 100 453101 3 20.11.2008 08:27:50 TM 251.258 16.81 17.15 17.17 16.81 16.77 17.13 17.27 16.84 16.84 16.66
GFM 1 111 453101 3 20.11.2008 08:42:06 TM 251.27 17.02 17.27 17.16 16.7 16.9 17.12 17.31 17.2 16.9 16.85
GFM 2 111 453101 3 20.11.2008 10:51:27 ES 251.311 16.38 16.6 16.34 16.25 16.34 16.64 16.58 15.81 16.78 16.28
Nach längerem testen hab ich festgestellt, dass das Makro filter1 noch nicht ganz passt.
Option Explicit
Option Base 1
Sub filter1()
Dim Lzeile As Long, zaehler1 As Long, zaehler2 As Long
Dim Auswahl As Variant
Set Auswahl = Worksheets("Data")
Lzeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Auswahl.Activate
ReDim ArrIndex(Lzeile) As Boolean
ReDim ArrQ(Lzeile, 3) As Variant
ReDim ArrZ(Lzeile, 3) As Variant
ArrQ() = Range("B2:D" & Lzeile + 1)
For zaehler1 = 1 To Lzeile
For zaehler2 = 1 To Lzeile
If ArrQ(zaehler1, 1) = ArrQ(zaehler2, 1) And ArrQ(zaehler1, 2) = ArrQ(zaehler2, 2) And ArrQ(zaehler1, 3) = ArrQ(zaehler2, 3) And zaehler1 <> zaehler2 Then
If ArrIndex(zaehler1) = False And ArrIndex(zaehler2) = False Then
If ArrZ(zaehler2, 1) <> ArrQ(zaehler1, 1) Then
ArrZ(zaehler1, 1) = ArrQ(zaehler2, 1)
ArrZ(zaehler1, 2) = ArrQ(zaehler2, 2)
ArrZ(zaehler1, 3) = ArrQ(zaehler2, 3)
ArrZ(zaehler2, 1) = ArrQ(zaehler1, 1)
ArrZ(zaehler2, 2) = ArrQ(zaehler1, 2)
ArrZ(zaehler2, 3) = ArrQ(zaehler1, 3)
ArrIndex(zaehler1) = True
ArrIndex(zaehler2) = True
End If
End If
End If
Next zaehler2
Next zaehler1
With Auswahl
.Range("B2:D" & Lzeile) = ArrZ()
.Columns("B").AutoFilter Field:=1, Criteria1:="="
.Rows("2:" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Delete Shift:=xlUp
.Cells.AutoFilter
.Columns("B:B").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Worksheets("Report").Activate
End Sub