AW: Nachfrage
23.01.2018 15:07:44
Werner
Hallo Daniel,
dann mit RemoveDuplicates, ist eine eizige Codzeile mehr.
Option Explicit
Public Sub Filtern_kopieren()
Dim loSpalteQ As Long, loZeileQ As Long, loLetzteZ As Long
Dim wsQ As Worksheet, wsZ As Worksheet
Set wsQ = ThisWorkbook.Worksheets("Händlerübersicht")
Set wsZ = ThisWorkbook.Worksheets("Auswertung Bedingung 18")
Application.ScreenUpdating = False
With wsQ
loZeileQ = .Cells(.Rows.Count, 2).End(xlUp).Row
loSpalteQ = .Cells(1, .Columns.Count).End(xlToLeft).Column
loLetzteZ = wsZ.Cells(wsZ.Rows.Count, 2).End(xlUp).Offset(1, 0).Row
.Range(.Cells(1, 1), .Cells(loZeileQ, loSpalteQ)).AutoFilter Field:=4, _
Criteria1:="=C", Operator:=xlOr, Criteria2:="=C2"
.AutoFilter.Range.Columns("K:K").Offset(1).Resize(.AutoFilter.Range.Columns("K:K") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 2).PasteSpecial Paste:=xlValues
.AutoFilter.Range.Columns("G:H").Offset(1).Resize(.AutoFilter.Range.Columns("G:H") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 4).PasteSpecial Paste:=xlValues
.AutoFilter.Range.Columns("J:J").Offset(1).Resize(.AutoFilter.Range.Columns("J:J") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 6).PasteSpecial Paste:=xlValues
.AutoFilter.Range.Columns("I:I").Offset(1).Resize(.AutoFilter.Range.Columns("I:I") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 7).PasteSpecial Paste:=xlValues
.AutoFilter.Range.Columns("AC:AC").Offset(1).Resize(.AutoFilter.Range.Columns("AC:AC") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 8).PasteSpecial Paste:=xlValues
.AutoFilter.Range.Columns("AB:AB").Offset(1).Resize(.AutoFilter.Range.Columns("AB:AB") _
.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
wsZ.Cells(loLetzteZ, 9).PasteSpecial Paste:=xlValues
If .AutoFilterMode Then .ShowAllData
End With
With wsZ
loLetzteZ = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(2, 1), .Cells(loLetzteZ, 1)).FormulaLocal = "=KALENDERWOCHE(B2)"
.Range(.Cells(2, 1), .Cells(loLetzteZ, 1)).Value = _
.Range(.Cells(2, 1), .Cells(loLetzteZ, 1)).Value
.Range(.Cells(2, 3), .Cells(loLetzteZ, 3)).FormulaLocal = "=TEXT(B2;""TTT"")"
.Range(.Cells(2, 3), .Cells(loLetzteZ, 3)).Value = _
.Range(.Cells(2, 3), .Cells(loLetzteZ, 3)).Value
.Range("$A$1:$I$" & loLetzteZ).RemoveDuplicates Columns:=6, Header:=xlYes
End With
Set wsQ = Nothing: Set wsZ = Nothing
Application.ScreenUpdating = True
End Sub
Gruß Werner