AW: Link zum alten Beitrag
13.02.2018 17:09:08
ChrisL
Hi
Langsam nimmt es den Umfang von Auftragsprogrammierung an. Mein Einsatz ist dann hiermit auch beendet.
https://www.herber.de/bbs/user/119775.xlsm
Die letzten 3 Zeilen kannst du anstelle Hidden auch Delete machen.
Sub Makro()
Const WSName As String = "ZuFa"
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim lZ As Long
On Error Resume Next
Application.DisplayAlerts = False
Sheets(WSName).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets("Tabelle2")
Set WS3 = Sheets.Add(After:=Sheets(Sheets.Count))
With WS3
.Name = WSName
WS1.Columns(1).Copy .Range("A1")
.Rows(1).Insert
WS2.Range("A2:A" & WS2.Cells(Rows.Count, 1).End(xlUp).Row).Copy .Cells(Rows.Count, 1).End( _
xlUp).Offset(1, 0)
.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
lZ = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1") = "Gefiltert nach Alter"
.Range("A1").Font.Bold = True
.Range("B2") = "Adresse1"
.Range("C2") = "Alter1"
.Range("D2") = "Alter2"
.Range("E2") = "Delta Alter"
.Range("B3:B" & lZ).Formula = "=IFERROR(VLOOKUP($A3,Tabelle1!$A:$D,2,0),""x"")"
.Range("C3:C" & lZ).Formula = "=IFERROR(VLOOKUP($A3,Tabelle1!$A:$D,4,0), ""--"")"
.Range("D3:D" & lZ).Formula = "=IFERROR(VLOOKUP($A3,Tabelle2!$A:$D,4,0), ""--"")"
.Range("E3:E" & lZ).Formula = "=IFERROR((C3-D3), ""----"" )"
.Range("A1:B" & lZ).Copy .Range("A" & lZ + 1)
.Range("A" & lZ + 1) = "Gefiltert nach Gewicht"
.Range("A" & lZ + 1).Font.Bold = True
.Range("C" & lZ + 2) = "Gewicht"
.Range("D" & lZ + 2) = "Gewicht2"
.Range("E" & lZ + 2) = "Delta Gewicht"
.Range("C" & lZ + 3 & ":C" & lZ * 2).Formula = "=IFERROR(VLOOKUP($A" & lZ + 3 & ",Tabelle1!$ _
A:$D,4,0), ""--"")"
.Range("D" & lZ + 3 & ":D" & lZ * 2).Formula = "=IFERROR(VLOOKUP($A" & lZ + 3 & ",Tabelle2!$ _
A:$D,4,0), ""--"")"
.Range("E" & lZ + 3 & ":E" & lZ * 2).Formula = "=IFERROR((C" & lZ + 3 & "-D" & lZ + 3 & "), _
""----"" )"
.Range("A1:B" & lZ).Copy .Range("A" & lZ * 2 + 1)
.Range("A" & lZ * 2 + 1) = "Gefiltert nach Adresse"
.Range("A" & lZ * 2 + 1).Font.Bold = True
.Range("C" & lZ * 2 + 2) = "Adresse2"
.Range("C" & lZ * 2 + 3 & ":C" & lZ * 3).Formula = "=IFERROR(VLOOKUP($A" & lZ * 2 + 3 & ", _
Tabelle2!$A:$D,2,0),""x"")"
.Columns.AutoFit
.Columns.AutoFilter
.Range("A:I").HorizontalAlignment = xlCenter
.Range("A:I").VerticalAlignment = xlCenter
.Range("B" & lZ * 2 + 3).FormatConditions.Add Type:=xlExpression, Formula1:="=$B" & lZ * 2 + _
3 & "<>$C" & lZ * 2 + 3
.Range("B" & lZ * 2 + 3).FormatConditions(1).Interior.Color = 65535
.Range("B" & lZ * 2 + 3).FormatConditions(1).ModifyAppliesToRange Range:=.Range("B" & lZ * _
2 + 3).Resize(lZ - 2, 2)
If Not Worksheets("Tabelle2").ToggleButton3 Then .Range("C" & lZ * 2 + 1 & ":C" & lZ * 3). _
EntireRow.Hidden = True
If Not Worksheets("Tabelle2").ToggleButton2 Then .Range("C" & lZ + 1 & ":C" & lZ * 2). _
EntireRow.Hidden = True
If Not Worksheets("Tabelle2").ToggleButton1 Then .Range("C1:C" & lZ).EntireRow.Hidden = _
True
End With
End Sub
cu
Chris