Solved

Permutations VBA

Posted on 2011-03-01
32
782 Views
Last Modified: 2012-08-14
Hi I'm hoping someone can help with my query although I know it is a tricky one.

I have a spreadsheet with 2 columns containing the following

ID1      WordA WordB WordC WordD
ID2      WordE WordF WordG
ID3      WordH WordI WordJ WordK WordL WordM
etc

What I require is all the permuations for each ID (I have 16000+) so I think it would have to get put into a text file and I'll probably split the spreadsheet into more manageable groups. The order is important, but I wouldn't want any permutations containing less than 3 words. The total number of words for each ID changes ranging from 3 to some with possibly 20 - which I know will create a lot of results.

The result I'm looking for would be something like this:

ID1 WordA WordB WordC
ID1 WordB WordA WordC
ID1 etc
ID1 WordA WordB WordC WordD
ID1 WordA WordB WordD WordC
ID1 etc
ID2 WordE WordG WordF
ID2 WordG WordF WordE
ID2 etc

Hopefully someone has done something similar before.

Many thanks



0
Comment
Question by:gordonn
  • 14
  • 9
  • 9
32 Comments
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35005433
I'm working on it...

I will use Excel 2003, but it should work in every version

Please stand by...

0
 

Author Comment

by:gordonn
ID: 35005439
Fantastic thank you!
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35005573
I am assuming there are no blank lines between each line listing the words? If there could be, then the code will be different.

Also will the columns always be columns "A" and "B"?
0
 

Author Comment

by:gordonn
ID: 35005690
Hi - no there wouldn't be any blank lines.
The only thing that's different is there could be some lines which only have 1 or 2 words so these wouldn't meet the minimum 3 requirement - sorry I should have stated this first.
The data is actually in different columns but it wouldn't be a problem for me to put it into A and B.
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35005712
OK...thanks....stand by
0
 

Author Comment

by:gordonn
ID: 35005753
Sorry I don't think I was fully clear. Basically if there is only 1 word return it, if there are 2 words return both permutations, but for all those 3 words and over not to return permutations with any less than 3 words.
Hope that makes sense.
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35005870
This is working out more complex than I thought....Please give me time....It may take a while
0
 

Author Comment

by:gordonn
ID: 35005887
That's no problem at all - I thought it was pretty complicated. Thank you!
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35006571
I have the answer...just cleaning up the code
0
 

Author Comment

by:gordonn
ID: 35006604
Wow - well done, I look forward to seeing it!
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35006919
OK here we go...Hope this is what you are after.

Note that the combinations are produced (as an example) as follows:

 A  B  C  D            ABC
                            ABD
                            ACD
                            BCD
                            ABCD

They do not include internal permutations
(BCA, BAC, CBA, DBA etc).

If you want internal permutations it will be much more involved.

Please let me know if that is in fact what you want as well.
Cheers...Chris (craisin)
                     
Option Explicit
Private Sub GetCombos()
  'Programmer:  Chris Raisin (craisin)
  'Date: March 2, 2011
  'This procedure is written in VBA (also runs under VB6) and is designed to
  'write to a file the various combinations of 3 or more words found on lines
  'within an Excel Spreadsheet.
  'It is a requirement that a single word is listed in Column 1 on each row of the spreadsheet,
  'and a group of one or more words, seperated by psaces, be in the second column of each row.
  'This solution was written for Question 26854665 within Experts Exchange and is totally
  'public domain - change where required!  :-)
  
  Dim oThisSheet As Object     'The spreadsheet containing the data
  Dim oRow As Object           'A row in the spreadsheet
  Dim nFile As Integer         'A Handle to store the File ID to which data is written
  Dim cFile As String          'The name of the file to which data is written
  Dim nWords As Integer        'The number of words found in the line of data
  Dim cWord1 As String         'The first word to be written out (always the word in Column 1)
  Dim cWords2 As String        'The words found in Column 2 of the spreadsheet for the current line being examined
  Dim cWords() As String       'The words stroed in cWords2 stored in an array
  Dim aPeg(20) As Byte         'Permutation "Pegs" used in working out the permutations (notice they are "Bytes")
  Dim nAt As Integer           'A position holder used when determining if there are too many spaces between words
  Dim x As Integer             'a Loop counter
  Dim i As Integer             'another loop counter
  Dim j As Integer             'and yet another! (breeding like flies!)
  Dim s As String              'a string variable holding the current combination to be written out
  Dim nUpper As Integer        'a variable holding the value of the maximum "Peg" used in combination calculations
  Dim bOpened As Boolean       'A value (True.False) used to flag whether the output file has been opened yet to receive values
  Dim nCombinations As Long    'The number of valid combinations found and written to file
  
  Set oThisSheet = ActiveSheet  'set the currently active worksheet as the one on which we will delve for combinations
  
  'Open a file to store the combinations (.txt File, but could be .csv if you wish
  nFile = FreeFile
  cFile = "C:\Documents and Settings\" + Environ("Username") + "\My Documents\WordCombos.txt"
  
  With oThisSheet
    'for each row in our worksheet
    For Each oRow In .Rows
      'store the value in the first column of the row (the ID word)
      cWord1 = .Cells(oRow.Row, 1).Value
      'store the values of the other words found in column 2 of the row
      cWords2 = Trim(.Cells(oRow.Row, 2).Value)
      Do While True
        'make sure there is only ONE space between each word
        nAt = InStr(cWords2, "  ")
        'search for instances of MORE than one space
        If nAt > 0 Then
          'and if one is found, trim it back by one space
          cWords2 = Left(cWords2, nAt - 1) + " " + Mid(cWords2, nAt + 2)
        Else
          'no more "double spaces" (or bigger) found so let's get out of this loop!
          Exit Do
        End If
        DoEvents   'you should always do this in loops to allow windows to do other things.
                   '(don't want to hog the processor)
      Loop
      cWords() = Split(cWords2, " ")
      'Now go through every combination if the number of words exceeds 2
      nWords = UBound(cWords)
      If nWords > 2 Then  'UBound is zero based, so if there are more than 2 values (words)
                          'This should be changed if you want fewer/greater minimum number of words
        'Fill the pegs with the permutation limit values (a strange yet interesting concept!)
        aPeg(0) = 1                   'The first peg  is initialized to 1
        For x = 1 To (nWords + 1)
          aPeg(x) = aPeg(x - 1) * 2   'The value is always double that of the previous peg!
        Next
        'calculate the maximimum Peg to be utilized (based on number of words)
        nUpper = 2 ^ (nWords + 1) - 1
        For i = 0 To nUpper
          'initialise the string which will hold the next combination
          s = ""
          'go through each word and see if it is "pegged" for inclusion and (if it is)
          'append it to our string of words in the current combination
          For j = 0 To nWords
            If i And aPeg(j) Then
              s = s & " " & cWords(j)
            End If
          Next
          'if there are 3 or more words in the listing
          '(remember, UBound() is zero based)
          If UBound(Split(s, " ")) > 2 Then
            'if we haven't opened our output file yet, let's do so
            If Not bOpened Then
              Open cFile For Output As #nFile
              'and flag it as opened so we will not try to open agin next time through
              bOpened = True
            End If
            'record the number of combinations found so far
            nCombinations = nCombinations + 1
            'and print the current combination out to the file (space seperated)
            'Change the " " to "," if you want comma delimited (e.g. in a CSV" file)
            Print #nFile, cWord1 & " " & s
          End If
          DoEvents 'Again, let the processor do other things in case we have MILLIONS of combos
                   'being processed
        Next
      End If
      DoEvents '(see comment above about reluctance to "hog" the processor)
    Next
  End With
 
  'If the file was opened, we must have some combinations, but we must close the fle first
  'before viewing it
  If bOpened Then
    Close #nFile
    'Show how many combinations wer added.
    MsgBox CStr(nCombinations) + " valid combinations written to file"
    'and then open the file to be viewed (warning - user can alter file using notepad -
    'so perhaps other method of viewing should be found if this is a requirement.
    Shell "notepad.exe " + cFile, vbMaximizedFocus
  Else
    'Message box just in case no combinations are found - we should tell the
    'operator that at least the program did something!  :-)
    MsgBox "No valid combinations found"
  End If
End Sub

Open in new window

0
 

Author Comment

by:gordonn
ID: 35007149
Hi Chris,

Thank you very much for sending that through I can see you've spent quite a bit of time on it - so thank you.

I really do need the internal permutations though - do you think it's possible?

I'm going to test what you've done anyway

Many thanks
0
 

Author Comment

by:gordonn
ID: 35007470
Hi Chris,

I definately would need the internal permutations - I know this would generate alot of results.

Apart from that it looks fantastic and does just what I need and the comments are really useful.

Is there any chance you could add the permutations in?

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35007541
OK, but it will take a wee bit longer. It is 1.30am here and I am teaching tomorrow, but I will do what I can as soon as possble.

Cheers
Chris
0
 

Author Comment

by:gordonn
ID: 35007601
Oh ok Chris of course, whenever you get chance that would be brilliant thank you!

Sorry it already kept you up so late!

0
 
LVL 41

Expert Comment

by:dlmille
ID: 35010155
I've been looking at this, too.  Wiki defines permutation of a set of objects is an arrangement of those objects into a particular order
http://en.wikipedia.org/wiki/Permutation

e.g., {1,2,3}, namely [1,2,3], [1,3,2], [2,1,3], [2,3,1], [3,1,2], and [3,2,1].

If you have 4 items, then you would get so many results of FOUR items, not 3, 2 or 1.

Are you looking for permutations, or combinations?

Dave

0
What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

 
LVL 41

Expert Comment

by:dlmille
ID: 35011976
Attached, please find word permutations, as requested.  I parsed the input into two columns.  I researched several developments of the permutation algorithm and settled on the Johnson-Trotter algorithm, found at website: http://www.xtremevbtalk.com/archive/index.php/t-168296.html, by Mathimagics.

This algorthm generates permutations of numbers, given N as the starting number.  I utilized the result as an index to an array, which was pre-loaded with each row's set of words.

Dave
WordPermutator-r2.xlsm
0
 
LVL 41

Accepted Solution

by:
dlmille earned 250 total points
ID: 35013044
The attached borrows from combination algorithm learnings here: http://www.xtremevbtalk.com/archive/index.php/t-139843.html (bees-knees approach) which I also adapted to WORD versus character manipulation.

We now have the capability to generate:

1 - Permutations of sets of words,  
2 - Permutations, followed by Combinations (on each permutated output) on sets of words,
3 - Combinations of sets of words, and  
4 - Combinations, followed by Permutations (on each combinated output) on sets of words.
Enjoy!

Dave
WordPermutatorNCombinator-r2.xlsm
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35013065
@Chris - I would have moved on, but I had already started working on this and had some effort into it when I saw your post.  Rather than capitulate, I plunged on ahead as it was quite the intellectual exercise and then I started reading about permutation/combination algorithms and... it came together rather quickly.

@gordon - hope this works!

Dave
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35013323
OK - here is my final code which does everything requested.

I hate the "spaghetti" nature of my final function (FindCombinations) - I WILL re-write it but in my haste to get this solution quickly out, I just let my mind run with it, leaving the cleaning up of coding standards to a later time (tonight!  :-)

Is this the solution you need?

Option Explicit

Private Sub GetCombos()
  'Programmer:  Chris Raisin (craisin)
  'Date: March 2, 2011
  'This procedure is written in VBA (also runs under VB6) and is designed to
  'write to a file the various combinations of 3 or more words found on lines
  'within an Excel Spreadsheet.
  'It is a requirement that a single word is listed in Column 1 on each row of the spreadsheet,
  'and a group of one or more words, seperated by psaces, be in the second column of each row.
  'This solution was written for Question 26854665 within Experts Exchange and is totally
  'public domain - change where required!  :-)
  
  Dim oThisSheet As Object     'The spreadsheet containing the data
  Dim oRow As Object           'A row in the spreadsheet
  Dim nFile As Integer         'A Handle to store the File ID to which data is written
  Dim cFile As String          'The name of the file to which data is written
  Dim nWords As Integer        'The number of words found in the line of data
  Dim cWord1 As String         'The first word to be written out (always the word in Column 1)
  Dim cWords2 As String        'The words found in Column 2 of the spreadsheet for the current line being examined
  Dim cWords() As String       'The words stroed in cWords2 stored in an array
  Dim aPeg(20) As Byte         'Permutation "Pegs" used in working out the permutations (notice they are "Bytes")
  Dim nAt As Integer           'A position holder used when determining if there are too many spaces between words
  Dim X As Integer             'a Loop counter
  Dim i As Integer             'another loop counter
  Dim j As Integer             'and yet another! (breeding like flies!)
  Dim S As String              'a string variable holding the current combination to be written out
  Dim nUpper As Integer        'a variable holding the value of the maximum "Peg" used in combination calculations
  Dim bOpened As Boolean       'A value (True.False) used to flag whether the output file has been opened yet to receive values
  Dim nCombinations As Long    'The number of valid combinations found and written to file
  
  Set oThisSheet = ActiveSheet  'set the currently active worksheet as the one on which we will delve for combinations
  
  'Open a file to store the combinations (.txt File, but could be .csv if you wish
  nFile = FreeFile
  cFile = "C:\Documents and Settings\" + Environ("Username") + "\My Documents\WordCombos.txt"
  
  With oThisSheet
    'for each row in our worksheet
    For Each oRow In .Rows
      'store the value in the first column of the row (the ID word)
      cWord1 = .Cells(oRow.Row, 1).Value
      'store the values of the other words found in column 2 of the row
      cWords2 = Trim(.Cells(oRow.Row, 2).Value)
      Do While True
        'make sure there is only ONE space between each word
        nAt = InStr(cWords2, "  ")
        'search for instances of MORE than one space
        If nAt > 0 Then
          'and if one is found, trim it back by one space
          cWords2 = Left(cWords2, nAt - 1) + " " + Mid(cWords2, nAt + 2)
        Else
          'no more "double spaces" (or bigger) found so let's get out of this loop!
          Exit Do
        End If
        DoEvents   'you should always do this in loops to allow windows to do other things.
                   '(don't want to hog the processor)
      Loop
      cWords() = Split(cWords2, " ")
      'Now go through every combination if the number of words exceeds 2
      nWords = UBound(cWords)
      If nWords > 2 Then  'UBound is zero based, so if there are more than 2 values (words)
                          'This should be changed if you want fewer/greater minimum number of words
        'Fill the pegs with the permutation limit values (a strange yet interesting concept!)
        aPeg(0) = 1                   'The first peg  is initialized to 1
        For X = 1 To (nWords + 1)
          aPeg(X) = aPeg(X - 1) * 2   'The value is always double that of the previous peg!
        Next
        'calculate the maximimum Peg to be utilized (based on number of words)
        nUpper = 2 ^ (nWords + 1) - 1
        For i = 0 To nUpper
          'initialise the string which will hold the next combination
          S = ""
          'go through each word and see if it is "pegged" for inclusion and (if it is)
          'append it to our string of words in the current combination
          For j = 0 To nWords
            If i And aPeg(j) Then
              S = S & " " & cWords(j)
            End If
          Next
          'if there are 3 or more words in the listing
          '(remember, UBound() is zero based)
          If UBound(Split(S, " ")) > 2 Then
            'if we haven't opened our output file yet, let's do so
            If Not bOpened Then
              Open cFile For Output As #nFile
              'and flag it as opened so we will not try to open again next time through
              bOpened = True
            End If
            'Now lets write out all the permutations
            WriteAllCombos nFile, cWord1, S, nCombinations
          End If
          DoEvents 'Again, let the processor do other things in case we have MILLIONS of combos
                   'being processed
        Next
      End If
      'DoEvents '(see comment above about reluctance to "hog" the processor)
    Next
  End With
 
  'If the file was opened, we must have some combinations, but we must close the file first
  'before viewing it
  If bOpened Then
    Close #nFile
    'Show how many combinations wer added.
    MsgBox CStr(nCombinations) + " valid combinations written to file"
    'and then open the file to be viewed (warning - user can alter file using notepad -
    'so perhaps other method of viewing should be found if this is a requirement.
    Shell "notepad.exe " + cFile, vbMaximizedFocus
  Else
    'Message box just in case no combinations are found - we should tell the
    'operator that at least the program did something!  :-)
    MsgBox "No valid combinations found"
  End If
End Sub

Private Sub WriteAllCombos(nFile As Integer, cWord1 As String, S As String, nCombinations As Long)
Dim N As Integer, X As Integer, P As Integer
Dim PhraseArray() As String
Dim nWords As Integer
Dim cWords() As String
cWords = Split(S, " ")
nWords = UBound(cWords) + 1
ReDim PhraseArray(0)
For N = 3 To nWords
  FindCombinations N, cWords, nCombinations, PhraseArray
Next N
For N = 0 To UBound(PhraseArray)
  If Len(PhraseArray(N)) > 0 Then
    Print #nFile, cWord1 & " " & PhraseArray(N)
  End If
Next
End Sub

Sub FindCombinations(N As Integer, cWords() As String, nCombinations As Long, PhraseArray() As String)
Dim M As Integer, L As Integer
Dim X As Integer
Dim bUseOnce As Boolean
Dim S As String
Dim NU() As Integer
Dim C() As Integer

M = UBound(cWords)

bUseOnce = True

ReDim C(M + 1)
ReDim NU(M)

L140:
If L <> N Then GoTo L9020

L8000:
  S = ""
  For X = 1 To N
    If Len(Trim(cWords(C(X)))) > 0 Then
      'if you want comma delimited data, change " " to "," (e.g. writing to a CSV file)
      S = S & cWords(C(X)) & "  "
    End If
  Next X
  
  If Len(S) > 0 Then
    'record the number of combinations found so far
    nCombinations = nCombinations + 1
    ReDim Preserve PhraseArray(nCombinations)
    PhraseArray(nCombinations) = Trim(S)
  End If

L9000:
  L = L + 1
  GoTo L9080

L9020:
  L = L + 1

L9040:
  C(L) = 1

L9050:
  DoEvents
  If bUseOnce Then
    If NU(C(L)) = 0 Then
      NU(C(L)) = 1
      GoSub L140
    End If
  Else
    GoSub L140
  End If

L9060:
  If C(L) < M Then
    C(L) = C(L) + 1
    GoTo L9050
  End If

L9080:
  If L > 1 Then
    L = L - 1
    NU(C(L)) = 0
    Return
  End If

End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35013502
On a re-read of the code, I suddenly realize that the first process of using "Pegs" simply provides combinations which are then passed to the WriteAllCombos() function, which writes out all the permutations  (perhaps I should rename it "WriteAllPenmus"?  :-)  )

When I re-write the code to remove the "spaghetti" coding (my apologies if you are of Italina extract) in the last module, I will investigate if this is the case. If so, then we can bypass the first process and simply launch straight into WriteAllCombos().

At least we have code available (which I will seperate into its own module) to
write combinations using the "Peg" precept"). Might be handy one day.

Anyway, I will clean it all up in about 12 hours, once i have finished teaching.
In the meantime it all seems to work as desired.

"I shall return!"  (somebody said that once)

Chris
(craisin)
0
 
LVL 13

Assisted Solution

by:Chris Raisin
Chris Raisin earned 250 total points
ID: 35014765
I have done SOME rewrite, and I was write about the first process using "Pegs" was not required, so I have removed that part of the code, renamed a few subroutines to correctly refplect their functions and rechecked the results to ensure that all is accurate

I still need to work out a nicer way to write "FindAllPermutations", but I must admit I came across this bit of logic in my scannign of the Internet, and although I hate the way it is written (an not commented), it works well. I MAY be able to fathom it out with a lot of "stepping through" in the debugger, but it seems the fastest most memory efficient way of doing things.

Please use this code instead of the previous code.

I think I might have to leave it there since I am exhausted and I hope the final output meets all your requirements.

Please let me know....

All the best

Chris (craisin)
Option Explicit

Private Sub GetCombos()
  'Programmer:  Chris Raisin (craisin)
  'Date: March 2, 2011
  'This procedure is written in VBA (also runs under VB6) and is designed to
  'write to a file the various combinations of 3 or more words found on lines
  'within an Excel Spreadsheet.
  'It is a requirement that a single word is listed in Column 1 on each row of the spreadsheet,
  'and a group of one or more words, seperated by psaces, be in the second column of each row.
  'This solution was written for Question 26854665 within Experts Exchange and is totally
  'public domain - change where required!  :-)
  
  Dim oThisSheet As Object     'The spreadsheet containing the data
  Dim oRow As Object           'A row in the spreadsheet
  Dim nFile As Integer         'A Handle to store the File ID to which data is written
  Dim cFile As String          'The name of the file to which data is written
  Dim nWords As Integer        'The number of words found in the line of data
  Dim cWord1 As String         'The first word to be written out (always the word in Column 1)
  Dim cWords2 As String        'The words found in Column 2 of the spreadsheet for the current line being examined
  Dim cWords() As String       'The words stroed in cWords2 stored in an array
  Dim aPeg(20) As Byte         'Permutation "Pegs" used in working out the permutations (notice they are "Bytes")
  Dim nAt As Integer           'A position holder used when determining if there are too many spaces between words
  Dim X As Integer             'a Loop counter
  Dim i As Integer             'another loop counter
  Dim j As Integer             'and yet another! (breeding like flies!)
  Dim S As String              'a string variable holding the current combination to be written out
  Dim nUpper As Integer        'a variable holding the value of the maximum "Peg" used in combination calculations
  Dim bOpened As Boolean       'A value (True.False) used to flag whether the output file has been opened yet to receive values
  Dim nCombinations As Long    'The number of valid combinations found and written to file
  
  Set oThisSheet = ActiveSheet  'set the currently active worksheet as the one on which we will delve for combinations
  
  'Open a file to store the combinations (.txt File, but could be .csv if you wish
  nFile = FreeFile
  cFile = "C:\Documents and Settings\" + Environ("Username") + "\My Documents\WordCombos.txt"
  
  With oThisSheet
    'for each row in our worksheet
    For Each oRow In .Rows
      'store the value in the first column of the row (the ID word)
      cWord1 = .Cells(oRow.Row, 1).Value
      'store the values of the other words found in column 2 of the row
      cWords2 = Trim(.Cells(oRow.Row, 2).Value)
      Do While True
        'make sure there is only ONE space between each word
        nAt = InStr(cWords2, "  ")
        'search for instances of MORE than one space
        If nAt > 0 Then
          'and if one is found, trim it back by one space
          cWords2 = Left(cWords2, nAt - 1) + " " + Mid(cWords2, nAt + 2)
        Else
          'no more "double spaces" (or bigger) found so let's get out of this loop!
          Exit Do
        End If
        DoEvents   'you should always do this in loops to allow windows to do other things.
                   '(don't want to hog the processor)
      Loop
      cWords() = Split(cWords2, " ")
      'Now go through every combination if the number of words exceeds 2
      nWords = UBound(cWords)
      If nWords > 2 Then  'UBound is zero based, so if there are more than 2 values (words)
                          'This should be changed if you want fewer/greater minimum number of words
        'if we haven't opened our output file yet, let's do so
        If Not bOpened Then
          Open cFile For Output As #nFile
          'and flag it as opened so we will not try to open again next time through
          bOpened = True
        End If
        'Now lets write out all the permutations
        WriteAllPerms nFile, cWord1, cWords, nCombinations
      End If
      DoEvents 'Again, let the processor do other things in case we have MILLIONS of combos
               'being processed
    Next
  End With
 
  'If the file was opened, we must have some combinations, but we must close the file first
  'before viewing it
  If bOpened Then
    Close #nFile
    'Show how many combinations wer added.
    MsgBox CStr(nCombinations) + " valid combinations written to file"
    'and then open the file to be viewed (warning - user can alter file using notepad -
    'so perhaps other method of viewing should be found if this is a requirement.
    Shell "notepad.exe " + cFile, vbMaximizedFocus
  Else
    'Message box just in case no combinations are found - we should tell the
    'operator that at least the program did something!  :-)
    MsgBox "No valid combinations found"
  End If
End Sub

Private Sub WriteAllPerms(nFile As Integer, cWord1 As String, cWords() As String, nCombinations As Long)
Dim N As Integer                'A loop counter for looping through words
Dim X As Integer                'A loop counter for looping through the calculated permutations
Dim PhraseArray() As String     'An array which carries the manipulated words returned when calculating permutations
Dim nWords As Integer           'The number of words being examined
nWords = UBound(cWords) + 1     'UBound() is zero based so we must add 1 to it to get number of words
ReDim PhraseArray(0)            'set up the array used to return the "rearranged" words for the next permutation
For N = 3 To nWords             'start at the 4rd word and work
  FindPermutations N, cWords, nCombinations, PhraseArray
Next N
For X = 0 To UBound(PhraseArray)
  If Len(PhraseArray(X)) > 0 Then
    Print #nFile, cWord1 & " " & PhraseArray(X)
  End If
Next
End Sub

Sub FindPermutations(nWords As Integer, cWords() As String, nCombinations As Long, PhraseArray() As String)
Dim M As Integer
Dim L As Integer
Dim X As Integer
Dim bUseOnce As Boolean
Dim S As String
Dim NU() As Integer
Dim C() As Integer

M = UBound(cWords)

bUseOnce = True

ReDim C(M + 1)
ReDim NU(M)

L140:
If L <> nWords Then GoTo L9020

L8000:
  S = ""
  For X = 1 To nWords
    If Len(Trim(cWords(C(X)))) > 0 Then
      'if you want comma delimited data, change " " to "," (e.g. writing to a CSV file)
      S = S & cWords(C(X)) & "  "
    End If
  Next X
  
  If Len(S) > 0 Then
    'record the number of combinations found so far
    nCombinations = nCombinations + 1
    ReDim Preserve PhraseArray(nCombinations)
    PhraseArray(nCombinations) = Trim(S)
  End If

L9000:
  L = L + 1
  GoTo L9080

L9020:
  L = L + 1

L9040:
  C(L) = 1

L9050:
  DoEvents
  If bUseOnce Then
    If NU(C(L)) = 0 Then
      NU(C(L)) = 1
      GoSub L140
    End If
  Else
    GoSub L140
  End If

L9060:
  If C(L) < M Then
    C(L) = C(L) + 1
    GoTo L9050
  End If

L9080:
  If L > 1 Then
    L = L - 1
    NU(C(L)) = 0
    Return
  End If
End Sub

Open in new window

0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35015045
Thanks for your comments Dave.

I note that your code will only run on Excel 2007 or later.

For the record, my code runs on any version of Excel 2003 or later.
It was unfortunate I could not run your code on my machine, since Excel 2003 (although it perform quite abit of backwards translation) could not load the ActiveX Controls you use nor use the multiple conditional formatting rules used within your code.

In spite of that, it is nice to see various options.
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35015054
Thanks - I can correct for the ActiveX Controls and will try to remember before hitting the hay (getting late).  The formatting is just for prettiness and not necessary.

Dave
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35015191
@gordon - when you review my post #35013044, be sure to see the drop down menus that allow for permutations with/without combinations, and combinations with/without permutations.

I believe you were looking for combinations with permutations on each combination and no set < 3 words (you have the option to set any minimum from 1 and up).  =3= That's what the current output should be displaying.

I've combed through the output a couple times and it appears to be correct, and also appears to match your output expectations, re: your original question/post (OP).

At Chris' good suggestion, attached here, is a XL 2003 Version, for better portability.  I just ran a test and got the same output as the much earlier posted version (see post # earlier in this note).

---------------------------
Attached, please find word permutations/combinations, as requested.  I parsed the input into two columns.  I researched several developments of the permutation algorithm and settled on the Johnson-Trotter algorithm, found at website: http://www.xtremevbtalk.com/archive/index.php/t-168296.html, by Mathimagics.

This algorthm generates permutations of numbers, given N as the starting number.  I utilized the result as an index to an array, which was pre-loaded with each row's set of words.


The attached also borrows from combination algorithm learnings here: http://www.xtremevbtalk.com/archive/index.php/t-139843.html (bees-knees approach) which I also adapted to WORD versus character manipulation.

We now have the capability to generate:


1 - Permutations of sets of words,  
2 - Permutations, followed by Combinations (on each permutated output) on sets of words,
3 - Combinations of sets of words, and  
4 - Combinations, followed by Permutations (on each combinated output) on sets of words.


Enjoy!

Dave



Cheers,

Dave
WordPermutatorNCombinator-r3-for.xls
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35015320
One last change I thought of you might find useful and your original post (OP) suggests it.  Rather than write to a .txt file you'd have to import, I created an option called Maximum Rows Per Sheet (a setting in yellow on the main tab).  Set that to anything from say 100 to 40,000.  It will chunk the data in multiple output tabs.

The attached has this modification.  There is already output generated for the sample data you posted.  One large output in the tab called "Output", and another run in "Outchunk_1", "Outchunk_2", "Outchunk_3", and "Outchunk_4" when I set the rough maximum number of rows to 500.  I can assist to chunk outputs on one tab, shifting to the right if needed. but, let's first see how this suits.

If you dump into "Output" only, by setting the range very high (50,000), you can run and rerun as it will erase the contents of "Output" at the start.  It does not, however, erase other tabs created on demand (per prior paragraph) or that may exist in your workbook, so you'll need to delete those if you are doing successive runs.

I hope you find this addition useful.

Cheers,

Dave
WordPermutatorNCombinator-r4.xls
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35016210
Nice idea Dave.

I sent it to a text file though because that is what the author requested in the original question. If the author asked for other options they would have been included.

Again, what you propose probably would not work with Excel in versions earlier than 2007 due to the high number of rows (would exceed Excel 2003 limitations).

Unless provisions are that  code need not work in environments other than 2007, then it is nest to stay with the file idea. (you can make it a comma delimited CSV file with a little tweaking of the code). That way, it can be read into ANY other program that reads comma delimited files (most programs) and even read back into an EXCEL file.

Since variety is the spice of life, your suggestions are certainly worth noting. I suppose it just depends on which method best fits the original question.

Cheers

I'm off to bed now to get some sleep (only had 4 hours in the last 32 hours) ,......zzzzzzzzzzzzz! (sound of quiet snoring fading into the distance....)  


0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35016272
Oooh....just woke up again.... :-)

Sorry about being persistent Dave at this question.

I am trying to stave off having to pay for EE membership since I have been out of work now for 24 months and am finding it hard to maintain my lifestyle (which includes membership to organisations) so I am trying to get as many points as I can each month.

I have earned just over 94,000 in the 11 years I have been with EE whereas you have close to 314,000 - hopefully the author will award us both something, but I would appreciate as many points as possible to help me in my quest to stave off membership cancellation (they already extended a free period to me of 12 weeks to help me out).

Anyway, enough grovelling....Let's just hope the solutions are what the author is after.

All the best

Chris (craisin)

(now I am REALLY off to bed!    :-)
0
 

Author Closing Comment

by:gordonn
ID: 35017241
Thank you both very much - they both did what I wanted, the text file was probably better for me but on running - Dave's appears very fast which will be useful as I have 16000+ rows to run it on.

Thanks again!
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35019675
Thanks for your comments.  However, you may have responded too soon.  

Before you tuck this away, test both and see if they give the same output.   I'm happy to share points, but want to make sure if there are any bugs we get the right code posted in this forum!

@Chris - mine works in 2003+ (and probably earlier) as you have the ability to chunk output into additional tabs.  Maybe you should load and try it :)  Since the OP suggested he was bringing it back into Excel, I went there, and if he'd really wanted it back in TXT files, I'd have accomodated, lol.

OK - I'll add the TXT option as I believe there's a logic problem with one of our solutions and I'm currently standing by mine.

Dave
0
 
LVL 41

Expert Comment

by:dlmille
ID: 35020280
Ok the attached has the option to create TXT files.  In the attached, I've generated all the output on the OUTPUT tab, and also done an option where the output was done in 500 row increments, creating different Ouput_chunk tabs.

Both the TXT file and XLS are attached - fully at least 2003 compatible.

@gordon - please check outputs to ensure they match in BOTH solutions - again, I believe there's a logic error in one of the solutions (I like mine :), but let's check) and I think its a good E-E practice to ensure the final product has had validation.

Cheers,

Dave
Output.txt
WordPermutatorNCombinator-r5.xls
0
 
LVL 13

Expert Comment

by:Chris Raisin
ID: 35024585
Dave is right!

I was not aware the results from my version were faulty - but I will (for the record) fix my version and post it here ASAP.

Thanks for the points, and thanks for your advice Dave.

Cheers
Chris (craisin)
0

Featured Post

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
How to Win a Jar of Candy Corn: A Scientific Approach! I love mathematics. If you love mathematics also, you may enjoy this tip on how to use math to win your own jar of candy corn and to impress your friends. As I said, I love math, but I gu…
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

757 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now