[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1299
  • Last Modified:

How to create a permutation algorithm or VB script

Please see attachment.  I am trying to create data sheets with every possible (horizontal) combination.  Anyhelp or suggestions where to start will be greatly appreiated.  
Configurator---Calculator.jpg
0
BajanPaul
Asked:
BajanPaul
  • 10
  • 4
  • 3
2 Solutions
 
BajanPaulAuthor Commented:
The item number must always be a 13 digit combination.  For the example above, I removed over 50+% of the letters.  Is there a script I could write in VB to generate all the possible combinations?  Once I have them, I plan to upload in SQL and query against them for the datasheets.
0
 
syeager305Commented:
http://www.codeguru.com/forum/archive/index.php/t-301647.html

If copy combine all the values in one cell, from line 4 in N1, then line 5 in O1, line 6 in P1, etc.  for example, N1 would be "OS001RLNNSNAT", O1 would be "MF113JGLSCTNN", then select these cells and run this code:


Const iIncrement As Integer = 1000
Dim PossPerm() As String
Dim iSize As Long
Dim iPos As Long
Dim myStr As String

Public Sub doAllPerms()
Dim rng As Excel.Range

If TypeName(Selection) <> "Range" Then Exit Sub

For Each rng In Selection.Cells
If Len(rng.Value) > 0 Then
Call MakePermutations(rng)
End If
Next rng
End Sub

Private Sub MakePermutations(rng As Excel.Range)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim myArr() As Integer
Dim myPerm() As String

Dim i As Long
Dim j As Long

Dim strTemp As String
myStr = rng.Value

ReDim myArr(0 To Len(myStr) - 1)

For i = LBound(myArr) To UBound(myArr)
myArr(i) = i + 1
Next i

iPos = 1
iSize = iIncrement
ReDim PossPerm(1 To iSize)

Call permuts(myArr, LBound(myArr), UBound(myArr) + 1)

If iPos < iSize Then
iSize = iPos
ReDim Preserve PossPerm(1 To iSize)
End If

ReDim myPerm(LBound(PossPerm) To UBound(PossPerm))

For i = LBound(PossPerm) To UBound(PossPerm)
For j = 1 To Len(PossPerm(i))
myPerm(i) = myPerm(i) & Mid(myStr, CInt(Mid(PossPerm(i), j, 1)), 1)
Next j
Next i

rng.Offset(1, 0).Resize(UBound(myPerm)).Value = _
Application.WorksheetFunction.Transpose(myPerm)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub permuts(ByRef myArr() As Integer, k As Integer, n As Integer)
Dim i As Integer
Dim temp As Integer

If (k = n - 1) Then
For i = 0 To n - 1
writeCurrent CStr(myArr(i))
Next i
writeNext
Else
For i = k To n - 1
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Call permuts(myArr, k + 1, n)
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Next i
End If
End Sub


Private Sub writeNext()
iPos = iPos + 1
If iPos > iSize Then
iSize = iSize + iIncrement
ReDim Preserve PossPerm(1 To iSize)
End If
End Sub

Private Sub writeCurrent(s As String)

PossPerm(iPos) = PossPerm(iPos) & s
End Sub

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
BajanPaulAuthor Commented:
If I wanted to combine all rows"Vertically" so for instance,

4    O     S    0
5    M     F    1
6    G     P    2
7                  3
8                  4
9                  6


N1=OMG
O1=SFP
P1=012346
Will this work?

Each Column multiplies against the other
0
 
BajanPaulAuthor Commented:
I've been playing with the VB code above.  The permutation happens within each column only.  I need the script to recognize each column independently, multiply and output in order.  For example, look at the headings:

Seri    -   Des    -    End    -    Ball    -     CL     -    Ed     -    TP    
O              S               0              0             1           R                  L
M              S               0              0             1           R                  L
G              S               0              0             1           R                  L

I hope I am explaining it clearly.

Thanks,
Paul
0
 
syeager305Commented:
... I still don't quite understand... the code that I sent works like this... a cell with a value "OMG" would be selected, in N1 for example, select it and run the VBA code, running the VBA code would drop all ther permuatation values below it.  
0
 
Bill PrewCommented:
I think you want to do something like this.  I didn't have time to add in all the columns you need, but you would just keep nesting the FOR loops.  In the innermost loop you have access to the value for each of the columns for this permutation.  I popped up a MsgBox, but you could also write these to a set of rows that you are generating.  Hope this helps, I'll check back later tonight and do more if needed.

Public Sub Test()
   Dim iA, iB, iC
   For iA = 4 To Cells(Cells.Rows.Count, "A").End(xlUp).Row
      For iB = 4 To Cells(Cells.Rows.Count, "B").End(xlUp).Row
         For iC = 4 To Cells(Cells.Rows.Count, "C").End(xlUp).Row
            MsgBox Cells(iA, "A").Value & Cells(iB, "B").Value & Cells(iC, "C").Value
         Next
      Next
   Next
End Sub

~bp
0
 
BajanPaulAuthor Commented:
You are right, it does work if I want to permutate the column "Seri" by itself.  I want to multiply all the letters within each column.  I also forgot to mention that the permutations cannot repeat and must be in order.

So for instance,

      Completed Figure Number                                                                        
      Seri      Des      End      Ball       CL      Ed      TP      "J"      "B"      "K"      "L"      "M"      "N"
        O      S      0      0      1      R      L      N      N      S      N      A      T
      O      S      1      0      1      R      L      N      N      S      N      A      T
      O      S      1      1      1      R      L      N      N      S      N      A      T

I need the output (permutations) structured and not to repeat.  

 
0
 
BajanPaulAuthor Commented:
I appreciate all your help thus far.
0
 
BajanPaulAuthor Commented:
Please see the attached excel sheet?
Copy-of-FigureNumber.xlsx
0
 
Bill PrewCommented:
Hmmm, if I read this right your test data will generate 197,492,188,608 rows, is that REALLY what you want???  (I got to that by 3*3*6*6*4*9*11*6*6*11*13*23*13)

Would the first 26 rows generated contain the following, or am I missing somethng?

OS001RLNNSNAT
OS001RLNNSNAN
OS001RLNNSNAP
OS001RLNNSNAM
OS001RLNNSNAY
OS001RLNNSNAZ
OS001RLNNSNAL
OS001RLNNSNAS
OS001RLNNSNAC
OS001RLNNSNAC
OS001RLNNSNAF
OS001RLNNSNAO
OS001RLNNSNAQ
OS001RLNNSNNT
OS001RLNNSNNN
OS001RLNNSNNP
OS001RLNNSNNM
OS001RLNNSNNY
OS001RLNNSNNZ
OS001RLNNSNNL
OS001RLNNSNNS
OS001RLNNSNNC
OS001RLNNSNNC
OS001RLNNSNNF
OS001RLNNSNNO
OS001RLNNSNNQ

~bp
0
 
BajanPaulAuthor Commented:
Yes.  I was asked to setup a database with all if not most of the figures numbers in it. I am creating a ms access database with a pretty extensive filter on it.  If all the figure numbers are generated then all the possible combinations will be there for the data sheets I am trying to generate.
0
 
BajanPaulAuthor Commented:
Hey Bill, I verified the first 26 rows up above and they are all correct.  How did you generate?
Paul
0
 
Bill PrewCommented:
>> BajanPaul

I just expanded on the concept in my above post (26175275) and added the remaining columns.

But I don't think generating these permutation in Excel will be effective, it will take a long time and do you really want all 200 billion?  That just seems like way to large a number of rows to be dealing with in Excel or Access to me.

~bp
0
 
BajanPaulAuthor Commented:
Bill,
I see your point.  The company I work for has been in business for over 50+ and I believe the engineers that setup the original figure # calculator did it like that for a reason, I can only assume to not run out of combinations.  
I am supposed to be meeting with Engineering today to see if we can weed down the figure number a bit.  Could you please explain what you have above as I have very limited knowledge of VB and I will try and write the rest myself.  Thanks for your help.
0
 
Bill PrewCommented:
Here is the code I ran.  But I had to kill it when I used your data it was running too long and generating too many rows in Sheet(2).

Public Sub Test()
   Dim i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, iOut
   Dim ws1 As Worksheet, ws2 As Worksheet
   Set ws1 = Sheets(1)
   Set ws2 = Sheets(2)
   iOut = 0
   Application.ScreenUpdating = False
   For i1 = 4 To ws1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
   For i2 = 4 To ws1.Cells(Cells.Rows.Count, 2).End(xlUp).Row
   For i3 = 4 To ws1.Cells(Cells.Rows.Count, 3).End(xlUp).Row
   For i4 = 4 To ws1.Cells(Cells.Rows.Count, 4).End(xlUp).Row
   For i5 = 4 To ws1.Cells(Cells.Rows.Count, 5).End(xlUp).Row
   For i6 = 4 To ws1.Cells(Cells.Rows.Count, 6).End(xlUp).Row
   For i7 = 4 To ws1.Cells(Cells.Rows.Count, 7).End(xlUp).Row
   For i8 = 4 To ws1.Cells(Cells.Rows.Count, 8).End(xlUp).Row
   For i9 = 4 To ws1.Cells(Cells.Rows.Count, 9).End(xlUp).Row
   For i10 = 4 To ws1.Cells(Cells.Rows.Count, 10).End(xlUp).Row
   For i11 = 4 To ws1.Cells(Cells.Rows.Count, 11).End(xlUp).Row
   For i12 = 4 To ws1.Cells(Cells.Rows.Count, 12).End(xlUp).Row
   For i13 = 4 To ws1.Cells(Cells.Rows.Count, 13).End(xlUp).Row
   iOut = iOut + 1
   ws2.Cells(iOut, 1).Value = ws1.Cells(i1, 1).Value
   ws2.Cells(iOut, 2).Value = ws1.Cells(i2, 2).Value
   ws2.Cells(iOut, 3).Value = ws1.Cells(i3, 3).Value
   ws2.Cells(iOut, 4).Value = ws1.Cells(i4, 4).Value
   ws2.Cells(iOut, 5).Value = ws1.Cells(i5, 5).Value
   ws2.Cells(iOut, 6).Value = ws1.Cells(i6, 6).Value
   ws2.Cells(iOut, 7).Value = ws1.Cells(i7, 7).Value
   ws2.Cells(iOut, 8).Value = ws1.Cells(i8, 8).Value
   ws2.Cells(iOut, 9).Value = ws1.Cells(i9, 9).Value
   ws2.Cells(iOut, 10).Value = ws1.Cells(i10, 10).Value
   ws2.Cells(iOut, 11).Value = ws1.Cells(i11, 11).Value
   ws2.Cells(iOut, 12).Value = ws1.Cells(i12, 12).Value
   ws2.Cells(iOut, 13).Value = ws1.Cells(i13, 13).Value
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Next
   Application.ScreenUpdating = True
End Sub

~bp
0
 
BajanPaulAuthor Commented:
Bill I will give it a try..Thanks for all your help.

PS
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 10
  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now