coping rows using a loop... please advise

[jim hensen]

Hello everyone i have a problem with a macro i am creating. There i
probably a really easy answer to this question, but i cant figure i
out. I need to know how to only copy the 4 rows following the cel
that contains "station number". These rows then need to be paste
into a new worksheet. This process must be done 12 times per wor
sheet. There are 12 cells containing the text "station number" and
need the 4 rows after each one. There are also numerous worksheet
that need to be procecced in the same manner. If anyone could help i
would be greatly appreciated.

P.S. I managed to create the code shown below. I dont know how muc
of it is correct. This is my first attempt at writing a macro


Dim Snum As Integer
Dim xi As Integer

Snum = 0
xi = 0
If (BSnum = STATION_NAME) Then
Range("B" & Snum :"BI" & (Snum + 3)").Select
Selection.Copy
Sheets("Sheet1").Select
Range("B" & xi).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone
SkipBlanks:= _
False, Transpose:=False
xi = xi + 4
Else
Snum = Snum + 1
End I

 

[Ron de Bruin]

Try this Jim

I use this range Sheets("Sheet1").Range("A1:A100")
It will copy the rows to "Sheet2"


Sub Copy_To_Another_Sheet_1()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long

Application.ScreenUpdating = False
'You can also use more values in the Array
MyArr = Array("station number")

Rcount = 1
With Sheets("Sheet1").Range("A1:A100")

For I = LBound(MyArr) To UBound(MyArr)
'Note : I use xlPart in this example and not xlWhole
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Offset(1).Resize(4).EntireRow.Copy _
Sheets("Sheet2").Rows(Rcount)
Set Rng = .FindNext(Rng)
Rcount = Rcount + 4
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
Application.ScreenUpdating = True
End Sub