AW: VBA - Duplikate unter Bedingung filtern
05.09.2018 20:53:02
Werner
Hallo,
zu 2. Meinst du so was?
Option Explicit
Sub Makro1()
Dim strName As String, loLetzte As Long, loLetzte1 As Long
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
strName = InputBox("bitte gesuchten Namen eingeben:", "Namen filtern")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
loLetzte1 = .Cells(.Rows.Count, 4).End(xlUp).Row
If Not strName = vbNullString Then
.Range(.Cells(2, 3), .Cells(loLetzte, 3)).FormulaLocal = _
"=WENN(ZÄHLENWENNS(A:A;""" & strName & """;B:B;B2)>1;0;"""")"
.Range(.Cells(2, 3), .Cells(loLetzte, 3)).Value = .Range(.Cells(2, 3), _
.Cells(loLetzte, 3)).Value
.Range(.Cells(2, 4), .Cells(loLetzte1, 5)).ClearContents
.Range("$A$1:$C$" & loLetzte).AutoFilter Field:=3, Criteria1:=0
.Range("$A$1:$C$" & loLetzte).AutoFilter Field:=1, Criteria1:=strName
If .Cells(.Rows.Count, 1).End(xlUp).Row > 1 Then
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1) _
.Columns("A:B").SpecialCells(xlCellTypeVisible).Copy
.Range("D2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.AutoFilterMode = False
.Columns("C:C").ClearContents
.Range("A1").Select
Else
MsgBox "Der gesuchte Name ist nicht vorhanden."
.AutoFilterMode = False
End If
End If
End With
Application.ScreenUpdating = True
End Sub
Bitte vor deinem eigentlichen Datenbereich noch eine Zeile mit Überschriften einfügen. Also in Zeile 1 Überschriften und die Daten dann ab Zeile 2. Zudem bin ich davon ausgegangen, dass die Spalte C frei (leer) ist. Dort schreibt das Makro eine Formel rein.
Gruß Werner