Hab schon viele dinge probiert mit suchen, finden, vom Macrorecorder was abschauen usw. - bin aber letztlich erfolglos geblieben. bitte um hilfe!
Sub kopieren()
Dim c As Range
Dim ersterFundort As String
Dim gleich As Boolean
With Range("h:h")
Set c = .Find(What:="texto:")
If Not (c Is Nothing) Then
ersterFundort = c.Address
Do
gleich = Vergleich_Zeile(c.Row, c.Row - 1)
If gleich Then
Cells(c.Row - 1, 10).Value = "'" & Cells(c.Row, 9).Value
Else
gleich = Vergleich_Zeile(c.Row, c.Row + 1)
If gleich Then
Cells(c.Row + 1, 10).Value = "'" & Cells(c.Row, 9).Value
End If
End If
Set c = .FindNext(c)
Loop While Not (c Is Nothing) And c.Address <> ersterFundort
End If
End With
End Sub
Function Vergleich_Zeile(aktZeile As Long, Zeile As Long) As Boolean
Dim I As Integer
Vergleich_Zeile = True
For I = 1 To 6
If Cells(aktZeile, I).Value <> Cells(Zeile, I).Value Then
Vergleich_Zeile = False
Exit For
End If
Next I
End Function
Sub kopieren()
ende = Cells(Rows.Count, 9).End(xlUp).Row 'die 9 ist die spalte
For I = ende To 2 Step -1
If Cells(I, 9) = "textto" Then 'hier auch
'hier deine zielort rein
End If
Next I
End Sub