AW: Duplikate filtern ohne Matrix und AutoFilter
23.01.2009 16:50:00
Tino
Hallo,
habe Deinen Code jetzt nicht getestet,
ich denke dass Filtern soll nach dem Kopiervorgang ausgeführt werden.
kommt als Code in die Tabelle
Option Explicit
Private Sub Worksheet_Activate()
'Zielblatt muss immer die höchste Nr. haben!
Dim i As Long
Dim j As Long
On Error GoTo Fehler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.Columns("B").ClearContents
ActiveSheet.Columns("C").ClearContents
ActiveSheet.Columns("D").ClearContents
ActiveSheet.Columns("E").ClearContents
ActiveSheet.Columns("F").ClearContents
ActiveSheet.Columns("G").ClearContents
ActiveSheet.Columns("H").ClearContents
With ActiveSheet
For i = 1 To ActiveWorkbook.Sheets.Count - 1 Step 1
Sheets(i).Range("C122:C218").Copy
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("N122:N218").Copy
.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("L122:L218").Copy
.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("I122:I218").Copy
.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("J122:J218").Copy
.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("G4:G100").Copy
.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Sheets(i).Range("D122:D218").Copy
.Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Next i
End With
Call Filtern 'Makro Filtern aufrufen
Fehler:
Application.CutCopyMode = False
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ActiveSheet.Range("A1").Select
End Sub
kommt in ein Modul
Option Explicit
Sub Filtern()
Dim Bereich As Range
'Spalte J leeren
Columns(10).Value = ""
'Benutzen Bereich ermitteln
Set Bereich = Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
'Bereich nach J Filtern ohne Duplikate
'Achtung die 1. Zelle wird als Überschrift mitgenommen
Bereich.AdvancedFilter xlFilterCopy, , Range("J1"), True
Range("J1") = "gefiltert" 'neue Überschrift
Range("J1").Font.Bold = True
End Sub
Gruß Tino