Hallo zusammen,

ich habe folgenden Code zur suche von bestimmten Daten in einer Excel- Tabelle. Dieser Code gibt mir aber, wenn mehrere gleichen Daten untereinander stehen nur jede zweite wieder. Ich habe schon stundenlang gesucht, kann den fehler aber nicht finden.

Kann mir jemand von euch helfen???

Private Sub optXXX_Click()
Dim zaehler1 As Long
Dim letzte As Long
Dim suche1 As Range
Dim wert As Variant
With Worksheets(2)

'' Tabellenblatt 1 Löschen
Sheets("Suchergebnis").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Liste1").Select

wert = "XXX"

For zaehler1 = 1 To Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Set suche1 = Worksheets(1).Range("C" & zaehler1 & ":C" & Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find(wert)

If Not suche1 Is Nothing Then
Sheets(1).Rows(suche1.Row).Copy
letzte = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Rows(letzte & ":" & letzte).Insert Shift:=xlDown
Sheets(1).Application.CutCopyMode = False
zaehler1 = suche1.Row
End If
Next zaehler1
End With
Sheets("Suchergebnis").Select
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("A1:W1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection.Font
.Name = "Arial"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Rows("1:1").Select
Selection.RowHeight = 30
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
ActiveCell.FormulaR1C1 = "Ergebnis der Suche"
Selection.Font.Bold = True
Range("A2").Select

Sheets("Liste1").Select
Rows("2").Select
Selection.Copy

Sheets("Suchergebnis").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Columns("A:W").Select
Range("A2").Activate
Selection.Columns.AutoFit
Range("A4:W1000").Select
Selection.Sort Key1:=Range("o3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
Range("A1:W1").Select
Application.CutCopyMode = False
Hide



End Sub



MfG

Axel