grabbing and moving data

[EDUCATED MONKEY]

Setup office 2007 win xp pro ie8<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
This is something I have done before but just can not remember how.<o></o>
Here is the problem in column A I have data that I wish to select in chucks and transfer those chucks to another sheet
Data in column A (section of) typical chuck size required 28 rows from the word (Enlarge)
Enlarge<o></o>
The Ultimate Havana<o></o>
Lantigua, John
ISBN: 9780451202789<o></o>
Format: Paperback<o></o>
Publisher:Signet Book<o></o>
Write a review <o></o>
Etc..
Loads of other data
Abc
123
Only need the 28 data row that follows the label (Enlarge) in each case
Down the entire column
Enlarge
28 rows >>> other sheet
Enlarge
28 rows >>> other sheet
Etc till end reached
The code I have been using does the first one then I can not get any further
So any ideas please

Option Explicit
Sub DistributData()
Dim Start As String
Dim test As String
Dim temp As String
Dim Last As String
Dim pointer As Long
Dim LR, N As Long
 
For N = 1 To 3
Worksheets("DeweyTest").Select  ' where the data is stored
 
Start = Application.WorksheetFunction.Match(" Enlarge", Range("A:A"), 0)
    Worksheets("DeweyTest").Cells(Start, 1).Value = ""
'MsgBox (Start)
 
Do While Start < 28 + Start
 
Worksheets("DeweyTest").Select
Worksheets("DeweyTest").Cells(Start, 1).Select
Selection.Copy
 
Worksheets("TestdeweyResults").Select
 
LR = Cells(Rows.Count, 1).End(xlUp).row + 1 ' looks in Col A
Cells(LR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   Start = Start + 1
   Loop
 
 
 
  Next N
 
 
 
End Sub

 

[JoeMo]

Try this. Assumes you want to cut 28 cells from columnA of the source sheet after each cell containing "Enlarge" and paste those cells sequentially in columnA of another sheet. Run this from the source sheet.

Sub MoveChunks()
Dim lRw1 As Long, lRw2 As Long, rng As Range, sSh As Worksheet, rSh As Worksheet
Dim sWhat As String, R As Range, firstHit As String
Const RwsToMove = 28 'change to suit

Set sSh = ActiveSheet
Set rSh = Sheets(sSh.Index + 1) 'Adjust sheet name or index to suit
lRw1 = sSh.Range("A" & Rows.Count).End(xlUp).Row
Set rng = sSh.Range("A1", "A" & lRw1)
sWhat = "Enlarge"
With rng
    Set R = .Find(sWhat, .Range("A" & lRw1), xlValues, xlWhole, _
        xlByRows, xlNext)
    If Not R Is Nothing Then
        firstHit = R.Address
        Do
            lRw2 = rSh.Range("A" & Rows.Count).End(xlUp).Row
            Range(R.Offset(1, 0), R.Offset(RwsToMove, 0)).Cut _
                rSh.Range("A" & lRw2 + 1)
            Set R = .FindNext(R)
        Loop Until R Is Nothing Or R.Address = firstHit
    End If
End With
End Sub

 

[EDUCATED MONKEY]

Hi thank you for your help, Read your code seems perfectly reasonable, <?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o> </o>
And works perfectly after I amend as recommend

 'This code written by member JoeMo
' 04 November 2011

Sub MoveChunks()
Dim lRw1 As Long, lRw2 As Long, rng As Range, sSh As Worksheet, rSh As Worksheet
Dim sWhat As String, R As Range, firstHit As String
Const RwsToMove = 28 'change to suit
Set sSh = Sheets("DeweyTest")
Set rSh = Sheets("TestdeweyResults")
'Set sSh = ActiveSheet
'Set rSh = Sheets(sSh.Index + 1) 'Adjust sheet name or index to suit
lRw1 = sSh.Range("A" & Rows.Count).End(xlUp).row
Set rng = sSh.Range("A1", "A" & lRw1)
sWhat = " Enlarge"
With rng
    Set R = .Find(sWhat, .Range("A" & lRw1), xlValues, xlWhole, _
        xlByRows, xlNext)
    If Not R Is Nothing Then
        firstHit = R.Address
        Do
            lRw2 = rSh.Range("A" & Rows.Count).End(xlUp).row
            Range(R.Offset(1, 0), R.Offset(RwsToMove, 0)).Cut _
                rSh.Range("A" & lRw2 + 1)
            Set R = .FindNext(R)
        Loop Until R Is Nothing Or R.Address = firstHit
    End If
End With
End Sub