Waarde zoeken, kopieren en plakken

[tommy1973]

Ik wil een waarde ("Adres:") in een Excel bestand zoeken, en vervolgens:
1. Deze waarde en de 4 cellen eronder willen kopieren
2. Deze willen plakken 2 cellen hoger in de kolom ernaast (kolom B) willen plakken

Als ik dit in een Makro maak lukt dit maar 1 keer terwijl er zo'n 500 adressen zijn.
Weet iemand hoe ik Range("B3:B8").Select en Range("C1").Select zo kan aanpassen dat dit voor alle 500 adressen lukt? Alvast bedankt!
---------------------------
Range("A1").Select
Cells.Find(What:="Adres:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.End(xlDown).Select
Range("B3:B8").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False

 

[Wigi]

Zoiets?

Sub zoeken()
Dim c As Range
For Each c In ActiveSheet.UsedRange
    If InStr(c, "Adres:") > 0 Then
        If c.Row < 3 Then
            MsgBox "Kan geen 2 rijen hoger"
        Else: c.Resize(5).Copy Range("B" & c.Row - 2)
        End If
    End If
Next
End Sub

Gebruik in het vervolg Code tags om je code leesbaar te maken.

Wigi

 

[tommy1973]

top!

Hi Wigi.

.....het werkt: Ontzettend bedankt!

Goed weekend!

Tom

 

[Wigi]

Hi Wigi.

.....het werkt: Ontzettend bedankt!

Goed weekend!

Tom

Tom

zet hem eens op opgelost aub. Merci