Looping through Ranges of Rows

  • Thread starter Thread starter MS News
  • Start date Start date
M

MS News

Here is my case:
I get raw data from offices, which I have to simply separate by
25 rows and make separate "nice" reports, for instance:

ID___NAME______AMOUNT

01---MIKE------$6600
XX---XXXX------$XXXX
91---JANET-----$4500

In the example above I have 91 rows of raw data.
If i did this manually I would have to make 4 reports out of
this, because every nice report that I make is supposed to have

25 records.

So how do I make a loop that will check every 25 row range for
data, and if data was found then copy all 25 rows and paste it on
a Report1, then check the next range from row 26 to 50. Again if
there's anything then copy and paste it on Report2 sheet, and so
on until the range has no data.

I would love to hear back from you on this matter,

Thanks a bunch,
Nile
 
Nile,

Try this. Start with the raw data sheet active, then run
the macro

Sub Make_Reports()

Dim iReport As Integer
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

'speed things up a bit
Application.ScreenUpdating = False

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While wsData.Cells(lRow, 1).Formula <> ""
'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & iReport
'copy headers
wsData.Range("A1:C1").Copy _
Destination:=wsReport.Range("A1")
'copy data (25 rows * 3 columns
wsData.Cells(lRow, 1).Resize(25, 3).Copy _
Destination:=wsReport.Range("A2")

iReport = iReport + 1
lRow = lRow + 25
Loop
End Sub

Cheers,
Dave
 
this macro will generate a report for every 25 records (creates a ne
work book for each one, report1, report2, etc. and creates one for th
remainder records also) ive tested this one, so you can just copy an
paste it. look at sheet references however (thisworkbook.sheets(1
should be your data page)
good luck!

Sub MakeReports()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set datasheet = ThisWorkbook.Sheets(1)
counter = 1
headernum = 1
Do While Cells(counter + headernum, 1).Value <> ""
counter = counter + 1
Loop
TotalRows = counter
fullreports = Int(TotalRows / 25)
remainder = TotalRows Mod 25
counter2 = 1
For counter = 1 To fullreports
t = "report" & counter
Set newBook = Workbooks.Add
With newBook
.Title = ""
.Subject = ""
.SaveAs Filename:="report" & counter & ".xls"
End With
Set currentreport = Workbooks("report" & counter & ".xls").Sheets(1)
For i = 1 To 25

datasheet.Activate
Cells(counter2, 1).EntireRow.Select
Selection.Copy
currentreport.Activate
currentreport.Cells(i, 1).Activate
ActiveSheet.Paste
counter2 = counter2 + 1
Next i
Next counter
Set newBook = Workbooks.Add
With newBook
.Title = ""
.Subject = ""
.SaveAs Filename:="report" & counter & ".xls"
End With
Set currentreport = Workbooks("report" & counter & ".xls").Sheets(1)
For i = 1 To remainder
datasheet.Activate
Cells(counter2, 1).EntireRow.Select
Selection.Copy
currentreport.Activate
currentreport.Cells(i, 1).Activate
ActiveSheet.Paste
counter2 = counter2 + 1
Next i
For i = 1 To fullreports
Workbooks("report" & i & ".xls").Save
Workbooks("report" & i & ".xls").Close
Next i
If remainder > 0 Then
Workbooks("report" & fullreports + 1 & ".xls").Save
Workbooks("report" & fullreports + 1 & ".xls").Close
End If
If remainder > 0 Then c = 1 Else c = 0
MsgBox "Reports completed - total: " & fullreports + c
End Su
 
I have a similar problem to this except that the data is in 10 columns and
col 1 may contain from 1 to 95 items that are identical in the first cell.
What I need is the ability to compare A2 with A3 and if the same then A4
with A3 and so on until A(x) is compared with the previous cell and at that
point create a new worksheet. An additional nice touch would be to name the
worksheet with the contents of the cell A1 eand subsequent data changes.
Example data:
A B C
1 Fred Dog Cat
2 Fred Fish Apple
3 Joe Item1 Item2
4 Joe Item1 Item3
5 Joe Item 2 Item3
In this case a new Worksheet would be created between Fred and Joe.

Thanks in advace for all your help

Don
 
The following assumes your 91 rows of data is in A2:C92 of a sheet named
"data"; it copies the data to a range with the upper left cell of A2 to
allow room on each Report sheet of the headings in row 1:

Sub testIt1()
Dim rng As Range, i As Long, j As Long
Set rng = Sheets("data").Range("a2: c92").Rows
If rng.Count Mod 25 = 0 Then
n = rng.Count \ 25
Else
n = rng.Count \ 25 + 1
End If
j = 1
For i = 1 To 25 * n Step 25
Worksheets.Add
ActiveSheet.Name = "Report" & j
rng.Rows(i & ":" & i + 24).Copy ActiveSheet.Range("A2")
j = j + 1
Next
End Sub

Alan Beban
 
You may want to look at Debra Dalgleish's site:

http://www.contextures.com/excelfiles.html

There are a couple of files you may want to steal from:

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- replaces old data with current.
AdvFilterCity.xls 55 kb
 
The following is more general than my previous posting; it assumes your
data is in columns a:c, indefinite number of rows up to 20,000 (which is
arbitrary--it can be increased as needed):

Sub testIt1()
Dim rng As Range, i As Long, j As Long
Set rng = Sheets("Sheet4").Range("a2: c2").Rows
j = 1
For i = 1 To 20000 Step 25
If Application.CountA(rng(i & ":" & i + 24).Cells) > 0 Then
Worksheets.Add
ActiveSheet.Name = "Report" & j
rng.Rows(i & ":" & i + 24).Copy ActiveSheet.Range("A2")
j = j + 1
Else
Exit Sub
End If
Next
End Sub

Alan Beban
 
Back
Top