Hallo nighty,
mein Code sieht jetzt so aus und funktioniert auch im Prinzip, aber für einen Spezialisten gibt es sicherlich einige Verbesserungen. Vielleicht könntest du dich noch mal mit dem Makro befassen.
Danke dir im Voraus für deine Hilfe.
Gruß
fedjo
Sub Suchen()
'aktuelle KW suchen
Dim strSuch As Integer
On Error Resume Next
strSuch = Sheets("Lieferzeiten").Range("A5").Value
lngAnz = WorksheetFunction.CountIf(Columns(3), strSuch)
Columns(3).Find(What:=strSuch, LookIn:=xlValues, lookat:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
ActiveCell.Offset(0, 3).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(3, 0)).Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
strSuch = Sheets("Lieferzeiten").Range("A5").Value
lngAnz = WorksheetFunction.CountIf(Columns(3), strSuch)
Columns(3).Find(What:=strSuch, LookIn:=xlValues, lookat:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
ActiveCell.Offset(0, 3).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(3, 0)).ClearContents
Range("F2:F" & ActiveCell.Row).ClearContents
End Sub