Is there a better way to do this macro code?

[zman]

Below is macro code I wrote, not the whole thing but a sample. Th
problem is the Sub length for my code is to long. Is there a way t
compress this code?

Public Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Sub PR1_Click()
'
' PR1_Click Macro
' Macro recorded 6/1/2004 by Lee
'
Dim destrange As range
Dim smallrng As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "pr1"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:

If Ash.Cells.range("B56") = "" Then GoTo one
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ")
Ash.Cells.range("A56") & (" - ") & Ash.Cells.range("B56")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo one
Exit Sub

one:
If Ash.Cells.range("B57") = "" Then GoTo two
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ")
Ash.Cells.range("A57") & (" - ") & Ash.Cells.range("B57")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo two
Exit Sub

and so on for about 200 more of the same with following consecutiv
numbers and ends like this...

onehundredfour:
If Ash.Cells.range("B162") = "" Then GoTo PT
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ")
Ash.Cells.range("A162") & (" - ") & Ash.Cells.range("B162")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo PT
Exit Sub

PT:
' If you want a empty row between each area use +2
Next smallrng


errorhandler:

range("A53").Select
'Application.Run "PR1_Click"
Application.Run "PR2_Click"
End Sub

I had to split it at onehundredfour because I got the error of sub to
long, so then I wanted to consolidate the next sub (pr2) to continue o
but I am not successful with that.

What all this does is take a column of data from the (cover page
worksheet and puts it on a worksheet called (pr1) to be printed i
rough draft form.

When I try to consolidate, I go from worksheet (pr2) and try to put i
on worksheet (pr1). Starting where (pr1) left off to continue th
column of data down.

Any help would be greatful.

Thank

 

[Anders Silven]

zman,

Your main problem is that you don't use a loop. There is no need for, and no
point in repeating almost identical pieces of code the way you do. With loops,
repetitive tasks can be compacted to a minimum.
Loops are such a fundamental tool in programming that I really recommend further
studies.
Loops can be set up in many ways and there are several statements for loop
constructs in VBA. What is the best way is often a matter of opinion.

Here is a small example to give you an idea of how it works.

'*****
Sub test6098()
' this sample will loop through B56:B162
' and enter something in A56:A162 where
' the cell in column B is not empty
Dim cRow As Integer
Dim Ash As Worksheet
Set Ash = ActiveSheet

For cRow = 56 To 162
With Ash.Cells(cRow, 2)
If .Value = "" Then GoTo nextRow

' demo
.Offset(0, -1).Value = cRow & .Value

' do the copying here,
' cRow contains the current row number

End With
nextRow:
Next cRow

End Sub
'*****

HTH
Anders Silven

 

[zman]

Here is a small example to give you an idea of how it works.

'*****
Sub test6098()
' this sample will loop through B56:B162
' and enter something in A56:A162 where
' the cell in column B is not empty
Dim cRow As Integer
Dim Ash As Worksheet
Set Ash = ActiveSheet

For cRow = 56 To 162
With Ash.Cells(cRow, 2)
If .Value = "" Then GoTo nextRow

' demo
.Offset(0, -1).Value = cRow & .Value

' do the copying here,
' cRow contains the current row number

End With
nextRow:
Next cRow

End Sub
'*****

HTH
Anders Silven


Thank you for the above code, but I do not understand all aspects o
it. So if there is more help out there, that would be appreciated.

The above code works to an extent but not all the way for me. What
do not understand is how to combine two columns. I would like t
append column A to Column B at the same time in this code and I a
unsuccessful in doing so. Below is the ultimate picture of what I'
looking for.

Steel Pipe - Plain End & C.I. Fittings…
--------------------------------------------------------------------------------------------------------------------------------------
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost
$1.56 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost
$3.35 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
--------------------------------------------------------------------------------------------------------------------------------------
Data: ----> 1 - Pipe - Plain End - Sch. 10 - 1 1/4" Amount [ 1 ]
cost [ $1.50 ]
Data: ----> 2 - Pipe - Plain End - Sch. 10 - 1 1/2" Amount [ 1 ]
cost [ $1.72 ]
Data: ----> 3 - Pipe - Plain End - Sch. 10 - 2" Amount [ 1 ] cost
$2.18 ]
Data: ----> 4 - Pipe - Plain End - Sch. 10 - 2 1/2" Amount [ 1 ]
cost [ $2.92 ]
Data: ----> 5 - Pipe - Plain End - Sch. 10 - 3" Amount [ 1 ] cost
$3.58 ]
Data: ----> 6 - Pipe - Plain End - Sch. 10 - 4" Amount [ 1 ] cost
$4.63 ]
Data: ----> 7 - Pipe - Plain End - Sch. 10 - 5" Amount [ 1 ] cost
$8.07 ]
Data: ----> 8 - Pipe - Plain End - Sch. 10 - 6" Amount [ 1 ] cost
$12.85 ]
Data: ----> 9 - Pipe - Plain End - Sch. 10 - 8" Amount [ 1 ] cost
$24.60 ]
--------------------------------------------------------------------------------------------------------------------------------------
Data: ----> 1 - Black C.I. Fittings - 45° EL - 1" Amount [ 1 ] cos
[ $1.01 ]
Data: ----> 2 - Black C.I. Fittings - 45° EL - 1 1/4" Amount [ 1 ]
cost [ $1.36 ]
Data: ----> 3 - Black C.I. Fittings - 45° EL - 1 1/2" Amount [ 1 ]
cost [ $2.24 ]
Data: ----> 4 - Black C.I. Fittings - 45° EL - 2" Amount [ 1 ] cos
[ $2.59 ]

so on and so forth... This info is found on sheet (pr1) as explaine
in my original posting. This is the result of my posted code. I a
trying to find a better way to do that code. Anders Silven code ha
helped, but the little knowledge I can find on the internet does no
help complete the task as I do not understand all aspects of his code.
So please help or guide me to more knowlege as I am grateful to learn
so I may complete this task.

Thanks,

zma

 

[Anders Silven]

Hi again zman,

In my reply I was just trying to help out with your immediate problem, that your
code is to long to fit in a module. The code I posted was meant as an example on
how you can compact the code and save a lot of typing, by using a loop instead
of repeating almost the same code over and over again. I did not try to solve
your specific problem.

Did you manage to set up a loop? If so, post the code and rephrase the question
in a new thread - hopefully one of the gurus will pick it up.

Best regards,
Anders Silven

Here is a small example to give you an idea of how it works.

'*****
Sub test6098()
' this sample will loop through B56:B162
' and enter something in A56:A162 where
' the cell in column B is not empty
Dim cRow As Integer
Dim Ash As Worksheet
Set Ash = ActiveSheet

For cRow = 56 To 162
With Ash.Cells(cRow, 2)
If .Value = "" Then GoTo nextRow

' demo
Offset(0, -1).Value = cRow & .Value

' do the copying here,
' cRow contains the current row number

End With
nextRow:
Next cRow

End Sub
'*****

HTH
Anders Silven


Thank you for the above code, but I do not understand all aspects of
it. So if there is more help out there, that would be appreciated.

The above code works to an extent but not all the way for me. What I
do not understand is how to combine two columns. I would like to
append column A to Column B at the same time in this code and I am
unsuccessful in doing so. Below is the ultimate picture of what I'm
looking for.

Steel Pipe - Plain End & C.I. Fittings…
------------------------------------------------------------------------------ --------------------------------------------------------
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost [
$1.56 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost [
$3.35 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
------------------------------------------------------------------------------ --------------------------------------------------------
Data: ----> 1 - Pipe - Plain End - Sch. 10 - 1 1/4" Amount [ 1 ]
cost [ $1.50 ]
Data: ----> 2 - Pipe - Plain End - Sch. 10 - 1 1/2" Amount [ 1 ]
cost [ $1.72 ]
Data: ----> 3 - Pipe - Plain End - Sch. 10 - 2" Amount [ 1 ] cost [
$2.18 ]
Data: ----> 4 - Pipe - Plain End - Sch. 10 - 2 1/2" Amount [ 1 ]
cost [ $2.92 ]
Data: ----> 5 - Pipe - Plain End - Sch. 10 - 3" Amount [ 1 ] cost [
$3.58 ]
Data: ----> 6 - Pipe - Plain End - Sch. 10 - 4" Amount [ 1 ] cost [
$4.63 ]
Data: ----> 7 - Pipe - Plain End - Sch. 10 - 5" Amount [ 1 ] cost [
$8.07 ]
Data: ----> 8 - Pipe - Plain End - Sch. 10 - 6" Amount [ 1 ] cost [
$12.85 ]
Data: ----> 9 - Pipe - Plain End - Sch. 10 - 8" Amount [ 1 ] cost [
$24.60 ]
------------------------------------------------------------------------------ --------------------------------------------------------
Data: ----> 1 - Black C.I. Fittings - 45° EL - 1" Amount [ 1 ] cost
[ $1.01 ]
Data: ----> 2 - Black C.I. Fittings - 45° EL - 1 1/4" Amount [ 1 ]
cost [ $1.36 ]
Data: ----> 3 - Black C.I. Fittings - 45° EL - 1 1/2" Amount [ 1 ]
cost [ $2.24 ]
Data: ----> 4 - Black C.I. Fittings - 45° EL - 2" Amount [ 1 ] cost
[ $2.59 ]

so on and so forth... This info is found on sheet (pr1) as explained
in my original posting. This is the result of my posted code. I am
trying to find a better way to do that code. Anders Silven code has
helped, but the little knowledge I can find on the internet does not
help complete the task as I do not understand all aspects of his code.
So please help or guide me to more knowlege as I am grateful to learn,
so I may complete this task.

Thanks,

zman

 

[zman]

Well in escence you answered all the questions previously put forth.
Thank you for you statements. Your reply on length of code and th
example helped out tremenduously. As progress is at least at hand. A
for a solution, it still eludes me.

Yes, I managed to perform a perfect loop, so to speak, using the cod
example. This loop only effects data retrieval from column (B)
however I was looking for data retrieval from column (A) and (B
simultaneously. Which I have not figured out. Hence, the last postin
by myself.

Now in new thought, I relise that column (A) is just a loop of numbers
So I post my new thoughts below, using the "For - Next loop style."
This is also unsuccessful, as now I recieve five groups of five dat
blocks, equivalent to 25 cells.

Dim destrange As range
Dim smallrng As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Dim aRow As Integer
Dim bRow As Integer
Dim nmbr As Integer

Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "pr1"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:

For nmbr = 1 To 5
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbr & ("
") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
'GoTo one
End With

nextRow:
Next bRow
Next nmbr
Exit Sub

PT:
Next smallrng

errorhandler:

range("A53").Select
'Application.Run "PR1_Click"
Application.Run "PR2_Click"
End Sub

And the result looks like this...

Steel Pipe - Plain End & C.I. Fittings…
--------------------------------------------------------------------------------------------------------------------------------------
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost
$1.56 ]
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost
$3.35 ]
Data: ----> 1 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost
$1.56 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost
$3.35 ]
Data: ----> 2 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost
$1.56 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost
$3.35 ]
Data: ----> 3 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost
$1.56 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost
$3.35 ]
Data: ----> 4 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 1" Amount [ 1 ] cost [
$1.56 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 1 1/4" Amount [ 1 ]
cost [ $2.08 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 1 1/2" Amount [ 1 ]
cost [ $2.50 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 2" Amount [ 1 ] cost [
$3.35 ]
Data: ----> 5 - Pipe - Plain End - Sch. 40 - 2 1/2" Amount [ 1 ]
cost [ $3.54 ]

Any ideas would be helpful...

Thanks,

Zman

 

[Anders Silven]

Hi again zman,

Good to see that you are making progress.

The reason you get an output of 25 rows is that you have written one loop inside
another, so for each iteration of the outer loop, the inner code is executed
five times. This is sometimes a useful technique, but here it gives an undesired
result.
You just want to use the variable nmbr as a simple counter, so try the following
modification (untested, but you'll get the idea) eliminating the outer loop. In
fact, nmbr is the same as (bRow - 55), but using nmbr makes the code easier to
read, so stick with that.

'*****
nmbr = 1
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbr & (" -
") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
'GoTo one
End With

nextRow:
nmbr = nmbr +1
Next bRow
'*****

HTH
Anders Silven

 

[zman]

I was straying off the path before you replied. I was going in the d
... while loop direction using a counter. The problem is it worked fo
the first section but for the other two sections the do ... while loo
got in the way of itself and I had no idea how to fix this. Below i
where I was going.

Dim destrange As range
Dim smallrng As range
Dim smallrngone As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Dim aRow As Integer
Dim bRow As Integer
Dim boneRow As Integer
Dim nmbr As Integer
Dim check, counter
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "pr1"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:

check = True: counter = 0
Do
Do While counter < 6
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
counter = counter + 1
smallrng = Ash.Cells.range("A55") & (" ----> ") & counter & (
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRow:

If counter = 6 Then
check = False
GoTo Lone
Exit Do
End If
Next bRow
Exit Sub

one:
Exit Do
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
MsgBox "one"
'check = True: counter = 6
'Do
'Do While counter < 10
'For boneRow = 63 To 71
'With Ash.Cells(bRow, 2)
'If .Value = "" Then GoTo nextRowone
'Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
'counter = counter + 1
'smallrngone = Ash.Cells.range("A55") & (" ----> ") & counter
(" - ") & .Value
'smallrngone.Copy
'destrange.PasteSpecial xlPasteValues
'End With

nextRowone:
'Next boneRow
Exit Sub

Lzero:
' If you want a empty row between each area use +2

Loop
Loop Until check = False

Next smallrng

Exit Sub
Lone:
MsgBox "lone"

'Loop
'Loop Until check = False
'Next smallrngone
Exit Sub
errorhandler:

range("A53").Select
'Application.Run "PR1_Click"
Application.Run "PR2_Click"
End Sub

Then you replied and not to soon there after a pretty picture arose.

Public Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Sub PR1_Click()
'
' PR1_Click Macro
' Macro recorded 6/1/2004 by Lee
'
Dim destrange As range
Dim smallrng As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Dim bRow As Integer
Dim bRowone As Integer
Dim bRowtwo As Integer
Dim nmbr As Integer
Dim nmbrone As Integer
Dim nmbrtwo As Integer
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "Print Out (1)"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:
nmbr = 1
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbr & (" -
") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRow:
nmbr = nmbr + 1
If nmbr = 6 Then
GoTo one
End If
Next bRow
Exit Sub

one:
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

nmbrone = 1
For bRowone = 63 To 71
With Ash.Cells(bRowone, 2)
If .Value = "" Then GoTo nextRowone
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbrone & ("
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRowone:
nmbrone = nmbrone + 1
If nmbrone = 10 Then
GoTo two
End If

Next bRowone
Exit Sub

two:
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

nmbrtwo = 1
For bRowtwo = 74 To 252
With Ash.Cells(bRowtwo, 2)
If .Value = "" Then GoTo nextRowtwo
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbrtwo & ("
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRowtwo:
nmbrtwo = nmbrtwo + 1
If nmbrtwo = 180 Then
GoTo PT
End If

Next bRowtwo
Exit Sub

Next smallrng

errorhandler:

PT:
newsh.PrintPreview
'newsh.PrintOut
Application.DisplayAlerts = False
'newsh.Delete
Application.DisplayAlerts = True

range("A53").Select

End Sub

And that's it... Exactly what I was looking for. I thank you for your
help.

Thanks,

Zman

 

[zman]

I was straying off the path before you replied. I was going in the d
... while loop direction using a counter. The problem is it worked fo
the first section but for the other two sections the do ... while loo
got in the way of itself and I had no idea how to fix this. Below i
where I was going.

Dim destrange As range
Dim smallrng As range
Dim smallrngone As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Dim aRow As Integer
Dim bRow As Integer
Dim boneRow As Integer
Dim nmbr As Integer
Dim check, counter
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "pr1"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:

check = True: counter = 0
Do
Do While counter < 6
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
counter = counter + 1
smallrng = Ash.Cells.range("A55") & (" ----> ") & counter & (
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRow:

If counter = 6 Then
check = False
GoTo Lone
Exit Do
End If
Next bRow
Exit Sub

one:
Exit Do
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
MsgBox "one"
'check = True: counter = 6
'Do
'Do While counter < 10
'For boneRow = 63 To 71
'With Ash.Cells(bRow, 2)
'If .Value = "" Then GoTo nextRowone
'Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
'counter = counter + 1
'smallrngone = Ash.Cells.range("A55") & (" ----> ") & counter
(" - ") & .Value
'smallrngone.Copy
'destrange.PasteSpecial xlPasteValues
'End With

nextRowone:
'Next boneRow
Exit Sub

Lzero:
' If you want a empty row between each area use +2

Loop
Loop Until check = False

Next smallrng

Exit Sub
Lone:
MsgBox "lone"

'Loop
'Loop Until check = False
'Next smallrngone
Exit Sub
errorhandler:

range("A53").Select
'Application.Run "PR1_Click"
Application.Run "PR2_Click"
End Sub

Then you replied and not to soon there after a pretty picture arose.

Public Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Sub PR1_Click()
'
' PR1_Click Macro
' Macro recorded 6/1/2004 by Lee
'
Dim destrange As range
Dim smallrng As range
Dim newsh As Worksheet
Dim Ash As Worksheet
Dim bRow As Integer
Dim bRowone As Integer
Dim bRowtwo As Integer
Dim nmbr As Integer
Dim nmbrone As Integer
Dim nmbrtwo As Integer
Set Ash = ActiveSheet
Set newsh = Worksheets.Add
newsh.Name = "Print Out (1)"
Ash.Select
range("A379").Select
newsh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.TopMargin = 60
newsh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
newsh.PageSetup.LeftHeader = "Estimate Sheet..."
newsh.PageSetup.CenterHeader = "Pioneer Fire Protection, Inc."
newsh.PageSetup.RightHeader = "&D"
newsh.PageSetup.CenterFooter = "Page &P of &N"

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
For Each smallrng In Selection.Areas
On Error GoTo errorhandler
smallrng = Ash.Cells.range("A381")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues
GoTo zero
Exit Sub
zero:
nmbr = 1
For bRow = 56 To 60
With Ash.Cells(bRow, 2)
If .Value = "" Then GoTo nextRow
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbr & (" -
") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRow:
nmbr = nmbr + 1
If nmbr = 6 Then
GoTo one
End If
Next bRow
Exit Sub

one:
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

nmbrone = 1
For bRowone = 63 To 71
With Ash.Cells(bRowone, 2)
If .Value = "" Then GoTo nextRowone
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbrone & ("
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRowone:
nmbrone = nmbrone + 1
If nmbrone = 10 Then
GoTo two
End If

Next bRowone
Exit Sub

two:
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("B383")
smallrng.Copy
destrange.PasteSpecial xlPasteValues

nmbrtwo = 1
For bRowtwo = 74 To 252
With Ash.Cells(bRowtwo, 2)
If .Value = "" Then GoTo nextRowtwo
Set destrange = newsh.Cells(LastRow(newsh) + 1, 1)
smallrng = Ash.Cells.range("A55") & (" ----> ") & nmbrtwo & ("
- ") & .Value
smallrng.Copy
destrange.PasteSpecial xlPasteValues
End With

nextRowtwo:
nmbrtwo = nmbrtwo + 1
If nmbrtwo = 180 Then
GoTo PT
End If

Next bRowtwo
Exit Sub

Next smallrng

errorhandler:

PT:
newsh.PrintPreview
'newsh.PrintOut
Application.DisplayAlerts = False
'newsh.Delete
Application.DisplayAlerts = True

range("A53").Select

End Sub

And that's it... Exactly what I was looking for. I thank you for your
help.

Thanks,

Zman

 

[Anders Silven]

zman,

Thank you for your feedback. There are still some things in your code that can
be simplified and some parts I don't understand - hard to do without the actual
data. But as they say, "If it works, don't fix it".

Regards
Anders Silven