Looking for a macro to automatically generate numbers in "cut-stack" order...

[gamouning]

Hi,

I need to create a macro which will automatically number a range of
tickets in "cut-stack" order. Another way this might be worded is,
given "nnn" sheets of paper, the order of each ticket number is
sequential on each subsequent sheet of paper. When the paper is cut the
stacks can be placed on top of each order to get a complete set of
numbered tickets.

For example, to number from 1 to 200 in stacks of 8, the first page
contains the following sequence of numbers:
1, 26, 51, 76, 101, 126, 151, 176
and the second page contains the following sequence of numbers:
2, 27, 52, 77, 102, 127, 152, 177
and the third page contains the following sequence of numbers:
3, 28, 53, 78, 103, 128, 153, 178
etc...

To get things started, I have defined the following cells in my current
worksheet:

A1=Calc_Num1
B1=Num1
C1=Start_Number
D1=Stop_Number
E1=N-up
F1=Increment

A2=C2
B2=RIGHT("0000"&A2,4)
C2=1
D2=200
E2=8
F2=ROUND((D2-C2)/E2,0)

A3=ROUND(D2/E2,0)+1
B3=RIGHT("0000"&A3,4)

A4=(A3+F2)
B4=RIGHT("0000"&A4,4)

A5=(A4+F2)
B5=RIGHT("0000"&A5,4)

A6=(A5+F2)
B6=RIGHT("0000"&A6,4)

A7=(A6+F2)
B7=RIGHT("0000"&A7,4)

A8=(A7+F2)
B8=RIGHT("0000"&A8,4)

A9=(A8+F2)
B9=RIGHT("0000"&A9,4)

A10=A2+1
B10=RIGHT("0000"&A10,4)

A11=A3+1
B11=RIGHT("0000"&A11,4)

The above formula is copied upto and including A201 and B201
respectively.

In the macro, I want to be prompted for the Start_Number, Stop_Number
and N-up cells in turn the macro will automatically populate all
required cells. Any assistance you can provide would be greatly
appreciated.

-Greg

 

[Mark]

I think I've worked something out that will do what you are asking.
There may be a way to reduce the code into a single sub, but I could
not figure how to do it without confusing myself. It seems to work
nicely as it is. Lemme know what ya think



Public Sub AutoCutStack(StartNumber As Integer, StopNumber As Integer,
_
StackNumber As Integer, StartCell As Range)

Dim Cnt() As Integer
Dim CurItem, StackMember As Integer, Looper, Stacker As Integer
'Calculate how many items will be in each stack in order
'to properly dimension the array.
StackMember = (StopNumber - StartNumber + 1) / StackNumber
'VERIFY THAT THE NUMBERS ENTERED CAN BE EVENLY DISTRIBUTED
If (StopNumber - StartNumber + 1) / StackNumber <> Int(StackMember)
Then
MsgBox "The Numbers you have input will not result " & _
"in an even distribution. Please recalculate and try again."
Exit Sub
End If
'Dimension the array to accommodate as many dimensions as there are
stacks
ReDim Cnt(1 To StackNumber, 1 To StackMember)
'loop through the array and populate it with the appropriate
numbers.
Stacker = 1 'Set to stack the first ticket
'This loop is to increment through the levels of the array in order
'to place the correct sequences in the appropriate levels
For Looper = 1 To StackNumber

For CurItem = StartNumber To StopNumber
Cnt(Looper, Stacker) = CurItem
'Debug.Print "Item# " & CurItem & " is located at posistion (" & Looper
& "'" & Stacker & ")"
'If all the stacks have recieved a number, then it is time
to reset
'to the first stack again and increment to the next level
in the array
If Looper = StackNumber Then
Looper = 0
Stacker = Stacker + 1
End If
Looper = Looper + 1
If CurItem = StopNumber Then
'The array is filled, now copy the contents to the
appropriate
'range
PrintArray StackNumber, StackMember, StartCell, Cnt
Exit Sub
End If
Next CurItem

Next Looper

End Sub

Sub PrintArray(Stacks As Integer, Members As Integer, StartRange As
Range, Items() As Integer)

Dim Cnt, x, y As Integer
Dim CurRng As Range

x = 1
y = 1
Cnt = 0

'Cycle through all of the stacks
Do Until y > Stacks

'Cycle through all of the members of one stack
Do Until x > Members
Set CurRng = StartRange.Offset(Cnt, 0)
CurRng = Items(y, x)
Debug.Print "Range(" & CurRng.Address & ") = " & CurRng; ""
Cnt = Cnt + 1
x = x + 1
Loop
y = y + 1
x = 1
Loop

End Sub

 

[gamouning]

Hi Mark,

Thanks for your prompt reply. Using the following instructions:

http://www.mvps.org/dmcritchie/excel/getstarted.htm

I tried installing the macro but it does not appear when I select
Alt-F8. Can you tell me what I might be doing wrong. I have uploaded a
sample file called, "Test Auto Cut Stack.xls". You can use the
following weblink to access this test file:

http://www.savefile.com/files/7447557

Thanks,
Greg

 

[Mark]

Short of me writting alot of code and creating an Add-In type feature
that you may or may not trust to run on your computer, try something
like this first...

enter the following in the same code module you already have...

Sub test()
AutoCutStack 1, 100, 4, Range("a1")
End Sub

If you hold your cursor on the AutoCutStack execution line and press
the F5 key, the command will execute. If you switch to the active
worksheet, you will see that a list has been generated from A1:A100.
If you are content to do this, all you have to do is change the Numbers
and the a1 between the quotes to get the results you want. I hope that
works. If not, I can make an add in for you but you will have to trust
I am not sabotaging your computer and I know that is tough to do these
days. Maybe you know enough code to look it over and see it is
harmless. Whatever, I hope this works

 

[gamouning]

Hi Mark,

Yes, including the "Test" macro to my module forces your AutoCutStack
macro to function. Does anyone know why this is happening and whether
it can be avoided without writing any additional code?

-Greg

 

[Mark]

-> > Sub test()

The reason that this routine must be performed manually instead of
using the macro shortcut window is because only Functions are contained
within the macro shortcut window. Functions are routines that return a
value. AutoCutStack was designed as a Subroutine because it wasn't
going to return 1 single value that could be placed in a given cell.
As I said the last time, I could design a user form that asks for the
four values that AutoCutStack uses and create that as an Excel AddIn.
I just figured that although a little sloppy this F5 method would do
what you needed it to do, without all the extra design work.