AW: hast du schon mal....
28.11.2019 17:53:26
Werner
Hallo,
teste mal:
Option Explicit
Sub SuchenErsetzen()
Dim loZeile As Long, loSpalte As Long
Dim raSort As Range
Application.ScreenUpdating = False
With Worksheets("Neu")
loZeile = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("H" & loZeile + 1) = 1
.Range("H" & loZeile + 1).Copy
.Range(.Cells(2, "A"), .Cells(loZeile, "A")).PasteSpecial Paste:=xlPasteAll, operation:= _
xlMultiply
Application.CutCopyMode = False
.Range("H" & loZeile + 1).ClearContents
End With
With Worksheets("Alt")
loZeile = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("H" & loZeile + 1) = 1
.Range("H" & loZeile + 1).Copy
.Range(.Cells(2, "A"), .Cells(loZeile, "A")).PasteSpecial Paste:=xlPasteAll, operation:= _
xlMultiply
Application.CutCopyMode = False
.Range("H" & loZeile + 1).ClearContents
End With
With Worksheets("Neu")
loZeile = .Cells(.Rows.Count, "A").End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).FormulaLocal = "=ZÄHLENWENN( _
Alt!A:A;A2)"
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value _
= .Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value
.Range(.Cells(1, 1), .Cells(loZeile, loSpalte + 1)).AutoFilter field:=loSpalte + 1, _
Criteria1:="1"
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
With Worksheets("Alt")
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row).PasteSpecial _
Paste:=xlPasteAll
Application.CutCopyMode = False
End With
If Worksheets("Neu").AutoFilterMode = True Then Worksheets("Neu").Rows("1:1").AutoFilter
.Columns(loSpalte + 1).ClearContents
End With
End With
With Worksheets("Alt")
loZeile = .Cells(.Rows.Count, "A").End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).FormulaLocal = _
"=ZEILE()"
.Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value _
= .Range(.Cells(2, loSpalte + 1), .Cells(loZeile, loSpalte + 1)).Value
Set raSort = .Range(.Cells(2, "A"), .Cells(loZeile, loSpalte + 1))
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range(.Cells(2, loSpalte + 1), _
.Cells(loZeile, loSpalte + 1)), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With .Sort
.SetRange raSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Range(.Cells(1, "A"), .Cells(loZeile, loSpalte + 1)).RemoveDuplicates Columns:=1, _
Header:=xlYes
loZeile = .Cells(.Rows.Count, "A").End(xlUp).Row
Set raSort = .Range(.Cells(2, "A"), .Cells(loZeile, loSpalte + 1))
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range(.Cells(2, "D"), .Cells(loZeile, "D")), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.SetRange raSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Columns(loSpalte + 1).Delete
End With
End Sub
Gruß Werner