Creating a Macro

[Guest]

Microsoft XP- Home Edition.

I want to create a macro that gives me the ability to list a set of numbers
and have them rearranged by a specific number.

Ex. #1
I have a set of 10 numbers, say:
1, 2, 3, 4, 5, 6, 7, 8, 9, 10
I want these numbers to be rearranged in the order of every third (3) number.
Therefore, the answer would be as follows:
3, 6, 9, 2, 7, 1, 8, 5, 10, 4


Ex. #2
I have a set of 20 numbers, say:
1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20
I want these numbers to be rearranged in the order of every seventh (7)
number.
Therefore, the answer would be as follows:
7, 14, 1, 9, 17, 5, ............etc.

Best Regards!

 

[Myrna Larson]

Here's a UDF that returns an array. It gives the results you show.

If you want every 3rd number from a set of 10, and the results are to go in a
horizontal range, select 10 cells in the same row, say C1:L1, and type the
formula

=EveryNth(10,3)

and press CTRL+SHIFT+ENTER. If you want the results in a column, select 10
cells all in the same column, say A1:A10, and use the formula

=TRANSPOSE(EveryNth(10, 3))

The number of cells that you must select is equal to the value of the first
argument. For the 7th number out of 20, you would select 20 cells and the
formula would be =EveryNth(20,7) or =TRANSPOSE(EveryNth(20,7))

I have assumed your original data is a sequence of integers, starting with 1.
I use 0 as a flag to indicate that a number has already been selected.

Out of curiosity, what is the purpose of this?


Option Explicit

Function EveryNth(Num As Long, Nth As Long)
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Variant
Dim y As Variant

ReDim x(1 To Num)
For i = 1 To Num
x(i) = i
Next i

ReDim y(1 To Num)

i = 0
j = 0
k = 0

Do
i = i + 1
If i > Num Then i = 1

If x(i) <> 0 Then
k = k + 1
If k = Nth Then
j = j + 1
y(j) = x(i)
If j = Num Then Exit Do
x(i) = 0
k = 0
End If
End If
Loop
EveryNth = y

End Function

 

[Guest]

Hello Myrna, I'm having trouble using this formula. I selected a row of 10
numbers (1-10 using a1..j1) and put in the formula you have listed below "
=EveryNth(10,3) " and I keep getting an error message (#NAME?). Can you help
me?

Thank You!

 

[JulieD]

Hi

not sure if Myrna is around, so i thought i would pop in to see if i could
help.

Myrna's formula creates the list of numbers in the order you specify. So
you don't select the numbers, you select blank cells, tell the formula how
many numbers to generate (i.e. 10) and in what sequence (i.e. 2 means the
numbers would be generated in the sequence of 2,4,6,8,10,1,3,5,7,9)

Before using this however, you need to copy the code that she gave you into
a module sheet in the VBE window. To do this, right mouse click on a sheet
tab, choose view code, choose insert / module - copy & paste the code there.
to get back to the workbook, press ALT & F11.

Hope this helps
Cheers
JulieD

 

[Guest]

Thank You Myrna and Julie!

The formula works!!!!!

Best Regards!

 

[Dana DeLouis]

Hi Myrna. I had a old code for this using the 'Collection' object, but I
find that your code is twice as fast on a larger set of numbers. So,
thanks!
I found this interesting, so I played around with it a little. On a large
set N, suppose one is skipping every 100th number. When the remaining
numbers to be found is say 2, the program scans all N numbers 50 times (or
50*2*N) just to get k = 100. I modified your excellent idea to include a
Mod function so that the main loop makes at most 1 pass on all N for each
increment. It looks like this decreases the number of loops by quite a bit
when working with a large set.
In certain math programs, they call this the "Josephus" problem (A
Permutation being the sequence of elimination when every nth member is
"eliminated." One wishes to be the "last man standing"). I've named it by
the same function name.

Sub TestIt()
Dim n As Long
Dim p As Long
Dim v

n = 20: p = 7
v = Josephus(n, p)
Range("A1").Resize(1, n) = v
End Sub

Function Josephus(Num As Long, Nth As Long)

Dim i As Long 'Loop pointer
Dim c As Long 'Counter 1 -> n
Dim Remain As Long '# Remaining
Dim n As Long 'Modified Nth
Dim x As Variant 'Input Array
Dim y As Variant 'Output Array


ReDim x(1 To Num)
ReDim y(1 To Num)

For i = 1 To Num
x(i) = i
Next i

Remain = Num
i = 0

Do While Remain > 0
n = Nth Mod Remain
If n = 0 Then n = Remain

c = 0
Do Until c = n
i = i + 1
If i > Num Then i = 1
c = c + Sgn(x(i))
Loop

y(Num - Remain + 1) = x(i)
x(i) = 0
Remain = Remain - 1
Loop
Josephus = y
'// Note: Last Number or Person "Picked" is # : y(num)
End Function

Thanks for the code ideas. :>)

 

[Myrna Larson]

Hi, Dana:

I thought it was interesting, too. I knew my code wasn't very efficient, but I
didn't spend any time trying to optimize it. Your code looks interesting.
Thanks for posting it.

Myrna Larson