Need some help with permutation code, convert from one cell to a range

J

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
4,546
Office Version
  1. 2007
Platform
  1. Windows
Hopefully, someone can assist me on how to convert a single cell of characters to permute to a range of cells that may change.

In other words, I have very fast code that can create permutations of characters from a single cell, but I am wondering how to make the code more flexible, ie, use multiple columns and rows as the input instead of just a single cell.

The following code is what I have for taking a single cell of character and running the permutations:
VBA Code: 
Sub MakePermutationsFromOneCell()
'
    Dim StartTime           As Single
    StartTime = Timer                                                                       ' Initialize StartTime
'
    Dim ArrayRow            As Long
    Dim InputStringLength   As Long
    Dim MaxPermutations     As Long
    Dim InputString         As String, PermutationString    As String
    Dim ResultsArray()      As String
'
    InputString = Range("A2").Value2                                                        ' Save string to Permut into InputString
    InputStringLength = Len(InputString)                                                    ' Save the length of the Permut string into InputStringLength
    MaxPermutations = WorksheetFunction.Permut(InputStringLength, InputStringLength)        ' Calculate the # of Permutations that will be generated from InputString
    PermutationString = ""                                                                  ' Initialize PermutationString
'
    ReDim ResultsArray(1 To MaxPermutations, 1 To 1)                                        ' Set the dimensions of the ResultsArray
'
    Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents                      ' Clear previous permutation results
'
    Call GetPermutationsRecursively(PermutationString, InputString, ArrayRow, ResultsArray) ' Get the permutations by passing variables to GetPermutationsRecursively
'
    Range("B2").Resize(ArrayRow).Value2 = ResultsArray                                      ' Display the permutation results to the sheet
'
    Debug.Print "Script completed in " & Timer - StartTime & " seconds."                    ' Display the completion time of the script to the 'Immediate' window (CTRL+G) in VBE
    MsgBox "Script completed in " & Timer - StartTime & " seconds."                         ' Display the completion time to a pop up window for the user
End Sub

Sub GetPermutationsRecursively(PermutationString As String, InputString As String, _
        ArrayRow As Long, ResultsArray() As String)
'
    Dim i   As Long, j  As Long
'
    j = Len(InputString)                                                                    ' Get the current length of InputString & save to j
'
    If j = 1 Then                                                                           ' If current length of InputString = 1 then ...
        ArrayRow = ArrayRow + 1                                                             '   Increment ArrayRow
        ResultsArray(ArrayRow, 1) = PermutationString & InputString                         '   Save this permutation string to ResultsArray
    Else                                                                                    ' Else ...
        For i = 1 To j                                                                      '   Loop
            Call GetPermutationsRecursively(PermutationString + Mid(InputString, i, 1), _
                    Left(InputString, i - 1) + Right(InputString, j - i), ArrayRow, _
                    ResultsArray)                                                           '
        Next                                                                                '   Loop back
    End If
End Sub

permutations list(1) (version 1).xlsb
AB
1Original stringPermutations
212345671234567
31234576
41234657
51234675
61234756
71234765
81235467
91235476
101235647
111235674
121235746
131235764
141236457
151236475
161236547
171236574
181236745
191236754
201237456
211237465
221237546
231237564
241237645
251237654
261243567
271243576
281243657
291243675
301243756
311243765
321245367
331245376
341245637
351245673
361245736
371245763
381246357
391246375
401246537
411246573
421246735
431246753
441247356
451247365
461247536
471247563
481247635
491247653
501253467
511253476
521253647
531253674
541253746
551253764
561254367
571254376
581254637
591254673
601254736
611254763
621256347
631256374
641256437
651256473
661256734
671256743
681257346
691257364
701257436
711257463
721257634
731257643
741263457
751263475
761263547
771263574
781263745
791263754
801264357
811264375
821264537
831264573
841264735
851264753
861265347
871265374
881265437
891265473
901265734
911265743
921267345
931267354
941267435
951267453
961267534
971267543
981273456
991273465
1001273546
1011273564
1021273645
1031273654
1041274356
1051274365
1061274536
1071274563
1081274635
1091274653
1101275346
1111275364
1121275436
1131275463
1141275634
1151275643
1161276345
1171276354
1181276435
1191276453
1201276534
1211276543
1221324567
1231324576
1241324657
1251324675
1261324756
1271324765
1281325467
1291325476
1301325647
1311325674
1321325746
1331325764
1341326457
1351326475
1361326547
1371326574
1381326745
1391326754
1401327456
1411327465
1421327546
1431327564
1441327645
1451327654
1461342567
1471342576
1481342657
1491342675
1501342756
1511342765
1521345267
1531345276
1541345627
1551345672
1561345726
1571345762
1581346257
1591346275
1601346527
1611346572
1621346725
1631346752
1641347256
1651347265
1661347526
1671347562
1681347625
1691347652
1701352467
1711352476
1721352647
1731352674
1741352746
1751352764
1761354267
1771354276
1781354627
1791354672
1801354726
1811354762
1821356247
1831356274
1841356427
1851356472
1861356724
1871356742
1881357246
1891357264
1901357426
1911357462
1921357624
1931357642
1941362457
1951362475
1961362547
1971362574
1981362745
1991362754
2001364257
2011364275
2021364527
2031364572
2041364725
2051364752
2061365247
2071365274
2081365427
2091365472
2101365724
2111365742
2121367245
2131367254
2141367425
2151367452
2161367524
2171367542
2181372456
2191372465
2201372546
2211372564
2221372645
2231372654
2241374256
2251374265
2261374526
2271374562
2281374625
2291374652
2301375246
2311375264
2321375426
2331375462
2341375624
2351375642
2361376245
2371376254
2381376425
2391376452
2401376524
2411376542
2421423567
2431423576
2441423657
2451423675
2461423756
2471423765
2481425367
2491425376
2501425637
2511425673
2521425736
2531425763
2541426357
2551426375
2561426537
2571426573
2581426735
2591426753
2601427356
2611427365
2621427536
2631427563
2641427635
2651427653
2661432567
2671432576
2681432657
2691432675
2701432756
2711432765
2721435267
2731435276
2741435627
2751435672
2761435726
2771435762
2781436257
2791436275
2801436527
2811436572
2821436725
2831436752
2841437256
2851437265
2861437526
2871437562
2881437625
2891437652
2901452367
2911452376
2921452637
2931452673
2941452736
2951452763
2961453267
2971453276
2981453627
2991453672
3001453726
3011453762
3021456237
3031456273
3041456327
3051456372
3061456723
3071456732
3081457236
3091457263
3101457326
3111457362
3121457623
3131457632
3141462357
3151462375
3161462537
3171462573
3181462735
3191462753
3201463257
3211463275
3221463527
3231463572
3241463725
3251463752
3261465237
3271465273
3281465327
3291465372
3301465723
3311465732
3321467235
3331467253
3341467325
3351467352
3361467523
3371467532
3381472356
3391472365
3401472536
3411472563
3421472635
3431472653
3441473256
3451473265
3461473526
3471473562
3481473625
3491473652
3501475236
3511475263
3521475326
3531475362
3541475623
3551475632
3561476235
3571476253
3581476325
3591476352
3601476523
3611476532
3621523467
3631523476
3641523647
3651523674
3661523746
3671523764
3681524367
3691524376
3701524637
3711524673
3721524736
3731524763
3741526347
3751526374
3761526437
3771526473
3781526734
3791526743
3801527346
3811527364
3821527436
3831527463
3841527634
3851527643
3861532467
3871532476
3881532647
3891532674
3901532746
3911532764
3921534267
3931534276
3941534627
3951534672
3961534726
3971534762
3981536247
3991536274
4001536427
4011536472
4021536724
4031536742
4041537246
4051537264
4061537426
4071537462
4081537624
4091537642
4101542367
4111542376
4121542637
4131542673
4141542736
4151542763
4161543267
4171543276
4181543627
4191543672
4201543726
4211543762
4221546237
4231546273
4241546327
4251546372
4261546723
4271546732
4281547236
4291547263
4301547326
4311547362
4321547623
4331547632
4341562347
4351562374
4361562437
4371562473
4381562734
4391562743
4401563247
4411563274
4421563427
4431563472
4441563724
4451563742
4461564237
4471564273
4481564327
4491564372
4501564723
4511564732
4521567234
4531567243
4541567324
4551567342
4561567423
4571567432
4581572346
4591572364
4601572436
4611572463
4621572634
4631572643
4641573246
4651573264
4661573426
4671573462
4681573624
4691573642
4701574236
4711574263
4721574326
4731574362
4741574623
4751574632
4761576234
4771576243
4781576324
4791576342
4801576423
4811576432
4821623457
4831623475
4841623547
4851623574
4861623745
4871623754
4881624357
4891624375
4901624537
4911624573
4921624735
4931624753
4941625347
4951625374
4961625437
4971625473
4981625734
4991625743
5001627345
5011627354
5021627435
5031627453
5041627534
5051627543
5061632457
5071632475
5081632547
5091632574
5101632745
5111632754
5121634257
5131634275
5141634527
5151634572
5161634725
5171634752
5181635247
5191635274
5201635427
5211635472
5221635724
5231635742
5241637245
5251637254
5261637425
5271637452
5281637524
5291637542
5301642357
5311642375
5321642537
5331642573
5341642735
5351642753
5361643257
5371643275
5381643527
5391643572
5401643725
5411643752
5421645237
5431645273
5441645327
5451645372
5461645723
5471645732
5481647235
5491647253
5501647325
5511647352
5521647523
5531647532
5541652347
5551652374
5561652437
5571652473
5581652734
5591652743
5601653247
5611653274
5621653427
5631653472
5641653724
5651653742
5661654237
5671654273
5681654327
5691654372
5701654723
5711654732
5721657234
5731657243
5741657324
5751657342
5761657423
5771657432
5781672345
5791672354
5801672435
5811672453
5821672534
5831672543
5841673245
5851673254
5861673425
5871673452
5881673524
5891673542
5901674235
5911674253
5921674325
5931674352
5941674523
5951674532
5961675234
5971675243
5981675324
5991675342
6001675423
6011675432
6021723456
6031723465
6041723546
6051723564
6061723645
6071723654
6081724356
6091724365
6101724536
6111724563
6121724635
6131724653
6141725346
6151725364
6161725436
6171725463
6181725634
6191725643
6201726345
6211726354
6221726435
6231726453
6241726534
6251726543
6261732456
6271732465
6281732546
6291732564
6301732645
6311732654
6321734256
6331734265
6341734526
6351734562
6361734625
6371734652
6381735246
6391735264
6401735426
6411735462
6421735624
6431735642
6441736245
6451736254
6461736425
6471736452
6481736524
6491736542
6501742356
6511742365
6521742536
6531742563
6541742635
6551742653
6561743256
6571743265
6581743526
6591743562
6601743625
6611743652
6621745236
6631745263
6641745326
6651745362
6661745623
6671745632
6681746235
6691746253
6701746325
6711746352
6721746523
6731746532
6741752346
6751752364
6761752436
6771752463
6781752634
6791752643
6801753246
6811753264
6821753426
6831753462
6841753624
6851753642
6861754236
6871754263
6881754326
6891754362
6901754623
6911754632
6921756234
6931756243
6941756324
6951756342
6961756423
6971756432
6981762345
6991762354
7001762435
7011762453
7021762534
7031762543
7041763245
7051763254
7061763425
7071763452
7081763524
7091763542
7101764235
7111764253
7121764325
7131764352
7141764523
7151764532
7161765234
7171765243
7181765324
7191765342
7201765423
7211765432
7222134567
7232134576
7242134657
7252134675
7262134756
7272134765
7282135467
7292135476
7302135647
7312135674
7322135746
7332135764
7342136457
7352136475
7362136547
7372136574
7382136745
7392136754
7402137456
7412137465
7422137546
7432137564
7442137645
7452137654
7462143567
7472143576
7482143657
7492143675
7502143756
7512143765
7522145367
7532145376
7542145637
7552145673
7562145736
7572145763
7582146357
7592146375
7602146537
7612146573
7622146735
7632146753
7642147356
7652147365
7662147536
7672147563
7682147635
7692147653
7702153467
7712153476
7722153647
7732153674
7742153746
7752153764
7762154367
7772154376
7782154637
7792154673
7802154736
7812154763
7822156347
7832156374
7842156437
7852156473
7862156734
7872156743
7882157346
7892157364
7902157436
7912157463
7922157634
7932157643
7942163457
7952163475
7962163547
7972163574
7982163745
7992163754
8002164357
8012164375
8022164537
8032164573
8042164735
8052164753
8062165347
8072165374
8082165437
8092165473
8102165734
8112165743
8122167345
8132167354
8142167435
8152167453
8162167534
8172167543
8182173456
8192173465
8202173546
8212173564
8222173645
8232173654
8242174356
8252174365
8262174536
8272174563
8282174635
8292174653
8302175346
8312175364
8322175436
8332175463
8342175634
8352175643
8362176345
8372176354
8382176435
8392176453
8402176534
8412176543
8422314567
8432314576
8442314657
8452314675
8462314756
8472314765
8482315467
8492315476
8502315647
8512315674
8522315746
8532315764
8542316457
8552316475
8562316547
8572316574
8582316745
8592316754
8602317456
8612317465
8622317546
8632317564
8642317645
8652317654
8662341567
8672341576
8682341657
8692341675
8702341756
8712341765
8722345167
8732345176
8742345617
8752345671
8762345716
8772345761
8782346157
8792346175
8802346517
8812346571
8822346715
8832346751
8842347156
8852347165
8862347516
8872347561
8882347615
8892347651
8902351467
8912351476
8922351647
8932351674
8942351746
8952351764
8962354167
8972354176
8982354617
8992354671
9002354716
9012354761
9022356147
9032356174
9042356417
9052356471
9062356714
9072356741
9082357146
9092357164
9102357416
9112357461
9122357614
9132357641
9142361457
9152361475
9162361547
9172361574
9182361745
9192361754
9202364157
9212364175
9222364517
9232364571
9242364715
9252364751
9262365147
9272365174
9282365417
9292365471
9302365714
9312365741
9322367145
9332367154
9342367415
9352367451
9362367514
9372367541
9382371456
9392371465
9402371546
9412371564
9422371645
9432371654
9442374156
9452374165
9462374516
9472374561
9482374615
9492374651
9502375146
9512375164
9522375416
9532375461
9542375614
9552375641
9562376145
9572376154
9582376415
9592376451
9602376514
9612376541
9622413567
9632413576
9642413657
9652413675
9662413756
9672413765
9682415367
9692415376
9702415637
9712415673
9722415736
9732415763
9742416357
9752416375
9762416537
9772416573
9782416735
9792416753
9802417356
9812417365
9822417536
9832417563
9842417635
9852417653
9862431567
9872431576
9882431657
9892431675
9902431756
9912431765
9922435167
9932435176
9942435617
9952435671
9962435716
9972435761
9982436157
9992436175
10002436517
10012436571
Sheet2


What I am looking for is some recursive code that can take a range of data for example A2:G4 & make permutations from the data in that range, not all cells in that range will have data, for example, Row 2 may have 7 entries, row 3 may have 3 entries, row 4 may have only 1 entry.

The display of results should contain the max # of data columns as the number of characters per permutation, so if the max number of characters in one row is 7 then all permutation results should be 7 characters long.

permutations list(1) (version 1).xlsb
ABCDEFGH
1
21234567
3123
456
5
Sheet4
 
Last edited:

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
Wow, due to the overwhelming responses thus far, I have decided to post the code that I have come up with for a solution, not saying it is the best solution, I'm sure it can be improved, just thought that I would post what I have come up with thus far in hopes of some better ideas that may be others can think of.

VBA Code: 
Sub PermutateRangeOfValues()
'
' This code will take the current region of data and make permutations from the values in the range
'
' Make sure each column of data does not have any blanks in between the values in the column
'
' There needs to be at least two rows of data in the region of data
'
    Dim StartTime                       As Single
    StartTime = Timer
'
    Dim ArrayColumn                     As Long, ArrayRow   As Long
    Dim NumberOfDataColumns             As Long
    Dim Permutations                    As Long
    Dim CurrentColumn                   As Long
    Dim ResultsRange                    As Range
    Dim delim                           As String
    Dim PermutationString               As String
    Dim ArrayOfLastRowsOfDataColumns()  As Long
    Dim DataArray()                     As Variant
    Dim ResultsArray()                  As String
'
    delim = "|"                                                                             ' <--- Set this to the delimiter that you want to use, "" = no delimiter ;)
'
    DataArray = Range("A1").CurrentRegion.Value2                                            ' Save the data range to DataArray
'
    NumberOfDataColumns = UBound(DataArray, 2)                                              ' Get the # of data columns
'
    Set ResultsRange = Cells(1, NumberOfDataColumns + 2)                                    ' Set the ResultsRange to be 2 columns to the right of the data range
'
    Columns(NumberOfDataColumns + 2).ClearContents                                          ' Clear any previous results
'
    ReDim ArrayOfLastRowsOfDataColumns(1 To NumberOfDataColumns)                            ' Establish the dimension of ArrayOfLastRowsOfDataColumns
'
    Permutations = 1                                                                        ' Initialize Permutations
'
    For ArrayColumn = 1 To NumberOfDataColumns                                              ' Loop through the column #s of data
        ArrayOfLastRowsOfDataColumns(ArrayColumn) = Range(Chr(64 + ArrayColumn) & _
                Rows.count).End(xlUp).Row                                                   '   Get the last row of the column & save to ArrayOfLastRowsOfDataColumns
        Permutations = Permutations * ArrayOfLastRowsOfDataColumns(ArrayColumn)             '   Multiply the last row of the column by the Permutations total thus far
    Next                                                                                    ' Loop back
'
    If Permutations > Rows.count Then                                                       ' If the permutations that will be generated > # of rows in one column then ...
        MsgBox "Too many permutations for this script to generate."                         '   Inform the user
        Exit Sub                                                                            '   Exit the script
    End If
'
    CurrentColumn = 1                                                                       ' Initialize CurrentColumn
    PermutationString = ""                                                                  ' Initialize PermutationString
'
    ReDim ResultsArray(1 To Permutations, 1 To 1)                                           ' Set the dimensions for ResultsArray
'
    GeneratePermutationsRecursive ResultsArray, ArrayRow, delim, CurrentColumn, DataArray, _
            ArrayOfLastRowsOfDataColumns, PermutationString                                 ' Pass variables to the recursive routine
'
    ResultsRange.Resize(Permutations).Value2 = ResultsArray                                 ' Display ResultsArray to the sheet
'
    ResultsRange.Columns.AutoFit                                                            ' AutoFit the width of the ResultsRange
'
    Debug.Print "Script completed in " & Timer - StartTime & " seconds."                    ' Display the completion time to the 'Immediate' window (CTRL+G) in the VBE
    MsgBox "Script completed in " & Timer - StartTime & " seconds."                         ' Display completion time in a pop up box to the user
End Sub

Sub GeneratePermutationsRecursive(ByRef ResultsArray() As String, ByRef ArrayRow As Long, _
        ByRef delim As String, ByRef CurrentColumn As Long, ByRef DataArray() As Variant, _
        ByRef ArrayOfLastRowsOfDataColumns() As Long, ByVal PermutationString As String)
'
    Dim i   As Long
'
    If CurrentColumn > UBound(ArrayOfLastRowsOfDataColumns) Then                            ' If we have reached the count for the PermutationString then ...
        ArrayRow = ArrayRow + 1                                                             '   Increment ArrayRow
'
        If delim <> "" Then                                                                 '   If there is a delim set then
            ResultsArray(ArrayRow, 1) = Left$(PermutationString, Len(PermutationString) - 1) '   Save the PermutationString to ResultsArray minus the trailing delim
        Else
            ResultsArray(ArrayRow, 1) = PermutationString                                   '   Save the PermutationString to ResultsArray
        End If
'
        Exit Sub                                                                            '
    End If
'
    For i = 1 To ArrayOfLastRowsOfDataColumns(CurrentColumn)                                '
        GeneratePermutationsRecursive ResultsArray, ArrayRow, delim, CurrentColumn + 1, _
                DataArray, ArrayOfLastRowsOfDataColumns, PermutationString & _
                DataArray(i, CurrentColumn) & delim                                         '
    Next                                                                                    ' Loop back
End Sub


permutations list(1) (version 1).xlsb
ABCDEFGHIJ
1ABCDEFGHA|B|C|D|E|F|G|H
2123A|B|C|D|3|F|G|H
345A|B|C||E|F|G|H
4A|B|C||3|F|G|H
5A|B|C|5|E|F|G|H
6A|B|C|5|3|F|G|H
7A|B|2|D|E|F|G|H
8A|B|2|D|3|F|G|H
9A|B|2||E|F|G|H
10A|B|2||3|F|G|H
11A|B|2|5|E|F|G|H
12A|B|2|5|3|F|G|H
13A||C|D|E|F|G|H
14A||C|D|3|F|G|H
15A||C||E|F|G|H
16A||C||3|F|G|H
17A||C|5|E|F|G|H
18A||C|5|3|F|G|H
19A||2|D|E|F|G|H
20A||2|D|3|F|G|H
21A||2||E|F|G|H
22A||2||3|F|G|H
23A||2|5|E|F|G|H
24A||2|5|3|F|G|H
25A|4|C|D|E|F|G|H
26A|4|C|D|3|F|G|H
27A|4|C||E|F|G|H
28A|4|C||3|F|G|H
29A|4|C|5|E|F|G|H
30A|4|C|5|3|F|G|H
31A|4|2|D|E|F|G|H
32A|4|2|D|3|F|G|H
33A|4|2||E|F|G|H
34A|4|2||3|F|G|H
35A|4|2|5|E|F|G|H
36A|4|2|5|3|F|G|H
371|B|C|D|E|F|G|H
381|B|C|D|3|F|G|H
391|B|C||E|F|G|H
401|B|C||3|F|G|H
411|B|C|5|E|F|G|H
421|B|C|5|3|F|G|H
431|B|2|D|E|F|G|H
441|B|2|D|3|F|G|H
451|B|2||E|F|G|H
461|B|2||3|F|G|H
471|B|2|5|E|F|G|H
481|B|2|5|3|F|G|H
491||C|D|E|F|G|H
501||C|D|3|F|G|H
511||C||E|F|G|H
521||C||3|F|G|H
531||C|5|E|F|G|H
541||C|5|3|F|G|H
551||2|D|E|F|G|H
561||2|D|3|F|G|H
571||2||E|F|G|H
581||2||3|F|G|H
591||2|5|E|F|G|H
601||2|5|3|F|G|H
611|4|C|D|E|F|G|H
621|4|C|D|3|F|G|H
631|4|C||E|F|G|H
641|4|C||3|F|G|H
651|4|C|5|E|F|G|H
661|4|C|5|3|F|G|H
671|4|2|D|E|F|G|H
681|4|2|D|3|F|G|H
691|4|2||E|F|G|H
701|4|2||3|F|G|H
711|4|2|5|E|F|G|H
721|4|2|5|3|F|G|H
73
Sheet4
 
Upvote 0
Sorry, in my last post I posted the results that happen when bad data range is used:

The following is what happens when the rules are followed:

permutations list(1) (version 1).xlsb
ABCDEFGHIJK
1ABCDEFGHA|B|C|D|E|F|G|H
214253A|B|C|D|3|F|G|H
3A|B|C|5|E|F|G|H
4A|B|C|5|3|F|G|H
5A|B|2|D|E|F|G|H
6A|B|2|D|3|F|G|H
7A|B|2|5|E|F|G|H
8A|B|2|5|3|F|G|H
9A|4|C|D|E|F|G|H
10A|4|C|D|3|F|G|H
11A|4|C|5|E|F|G|H
12A|4|C|5|3|F|G|H
13A|4|2|D|E|F|G|H
14A|4|2|D|3|F|G|H
15A|4|2|5|E|F|G|H
16A|4|2|5|3|F|G|H
171|B|C|D|E|F|G|H
181|B|C|D|3|F|G|H
191|B|C|5|E|F|G|H
201|B|C|5|3|F|G|H
211|B|2|D|E|F|G|H
221|B|2|D|3|F|G|H
231|B|2|5|E|F|G|H
241|B|2|5|3|F|G|H
251|4|C|D|E|F|G|H
261|4|C|D|3|F|G|H
271|4|C|5|E|F|G|H
281|4|C|5|3|F|G|H
291|4|2|D|E|F|G|H
301|4|2|D|3|F|G|H
311|4|2|5|E|F|G|H
321|4|2|5|3|F|G|H
33
Sheet4
 
Upvote 0
Another update to allow multiple columns of results:

permutations list(1).xlsm
ABCDEFGHIJKLM
1aaaaaaaaa|a|a|a|a|a|a|ae|g|d|e|f|d|a|ej|g|c|b|e|g|b|c
2bbbbbbbba|a|a|a|a|a|a|be|g|d|e|f|d|a|fj|g|c|b|e|g|b|d
3ccccccca|a|a|a|a|a|a|ce|g|d|e|f|d|b|aj|g|c|b|e|g|b|e
4ddddddda|a|a|a|a|a|a|de|g|d|e|f|d|b|bj|g|c|b|e|g|b|f
5eeeeeeea|a|a|a|a|a|a|ee|g|d|e|f|d|b|cj|g|c|b|e|h|a|a
6ffffffa|a|a|a|a|a|a|fe|g|d|e|f|d|b|dj|g|c|b|e|h|a|b
7gggga|a|a|a|a|a|b|ae|g|d|e|f|d|b|ej|g|c|b|e|h|a|c
8hhha|a|a|a|a|a|b|be|g|d|e|f|d|b|fj|g|c|b|e|h|a|d
9iia|a|a|a|a|a|b|ce|g|d|e|f|e|a|aj|g|c|b|e|h|a|e
10jja|a|a|a|a|a|b|de|g|d|e|f|e|a|bj|g|c|b|e|h|a|f
11ka|a|a|a|a|a|b|ee|g|d|e|f|e|a|cj|g|c|b|e|h|b|a
12a|a|a|a|a|a|b|fe|g|d|e|f|e|a|dj|g|c|b|e|h|b|b
13a|a|a|a|a|b|a|ae|g|d|e|f|e|a|ej|g|c|b|e|h|b|c
14a|a|a|a|a|b|a|be|g|d|e|f|e|a|fj|g|c|b|e|h|b|d
15a|a|a|a|a|b|a|ce|g|d|e|f|e|b|aj|g|c|b|e|h|b|e
16a|a|a|a|a|b|a|de|g|d|e|f|e|b|bj|g|c|b|e|h|b|f
17a|a|a|a|a|b|a|ee|g|d|e|f|e|b|cj|g|c|b|e|i|a|a
18a|a|a|a|a|b|a|fe|g|d|e|f|e|b|dj|g|c|b|e|i|a|b
19a|a|a|a|a|b|b|ae|g|d|e|f|e|b|ej|g|c|b|e|i|a|c
20a|a|a|a|a|b|b|be|g|d|e|f|e|b|fj|g|c|b|e|i|a|d
21a|a|a|a|a|b|b|ce|g|d|e|f|f|a|aj|g|c|b|e|i|a|e
22a|a|a|a|a|b|b|de|g|d|e|f|f|a|bj|g|c|b|e|i|a|f
23a|a|a|a|a|b|b|ee|g|d|e|f|f|a|cj|g|c|b|e|i|b|a
24a|a|a|a|a|b|b|fe|g|d|e|f|f|a|dj|g|c|b|e|i|b|b
25a|a|a|a|a|c|a|ae|g|d|e|f|f|a|ej|g|c|b|e|i|b|c
26a|a|a|a|a|c|a|be|g|d|e|f|f|a|fj|g|c|b|e|i|b|d
27a|a|a|a|a|c|a|ce|g|d|e|f|f|b|aj|g|c|b|e|i|b|e
28a|a|a|a|a|c|a|de|g|d|e|f|f|b|bj|g|c|b|e|i|b|f
29a|a|a|a|a|c|a|ee|g|d|e|f|f|b|cj|g|c|b|e|j|a|a
30a|a|a|a|a|c|a|fe|g|d|e|f|f|b|dj|g|c|b|e|j|a|b
Sheet1



VBA Code: 
Sub PermutateRangeOfValuesMaxOneMillionRowsPerColumn()
'
' This code will take the current region of data and generate permutations from the values in the range
'
' Make sure each column of data does not have any blanks in between the values in the column
'
' There needs to be at least two rows of data in the region of data
'
' The defaults in this code will display the permutations generated in chunks of 1,000,000 rows, then
'   jump to the next column for the next chunk of results until all permutations have been displayed
'
    Dim StartTime                       As Single
    StartTime = Timer
'
    Dim ArrayColumn                     As Long, ArrayRow   As Long
    Dim CurrentColumn                   As Long
    Dim CurrentPermutationIndex         As Long
    Dim NumberOfDataColumns             As Long
    Dim TotalPermutations               As Long
    Dim ResultsRange                    As Range
    Dim PermutationString               As String
    Dim ArrayOfLastRowsOfDataColumns()  As Long
    Dim DataArray()                     As Variant
    Dim ResultsArray()                  As String
'
    Const delim                         As String = "|"                                     ' <--- Set this to the delimiter that you want to use, "" = no delimiter ;)
    Const MaxRowsPerColumn              As Long = 1000000                                   ' <--- Set this to the MaxRowsPerColumn
'
    DataArray = Range("A1").CurrentRegion.Value2                                            ' Save the data range to DataArray
'
    NumberOfDataColumns = UBound(DataArray, 2)                                              ' Get the # of data columns
'
    Set ResultsRange = Cells(1, NumberOfDataColumns + 2)                                    ' Set the ResultsRange to be 2 columns to the right of the data range
    Columns(NumberOfDataColumns + 2).CurrentRegion.ClearContents                            ' Clear any previous results
'
    ReDim ArrayOfLastRowsOfDataColumns(1 To NumberOfDataColumns)                            ' Establish the dimension of ArrayOfLastRowsOfDataColumns
'
    TotalPermutations = 1                                                                   ' Initialize TotalPermutations
'
    For ArrayColumn = 1 To NumberOfDataColumns                                              ' Loop through the column #s of data
        ArrayOfLastRowsOfDataColumns(ArrayColumn) = Range(Chr(64 + ArrayColumn) & _
                Rows.count).End(xlUp).Row                                                   '   Get the last row of the column & save to ArrayOfLastRowsOfDataColumns
        TotalPermutations = TotalPermutations * ArrayOfLastRowsOfDataColumns(ArrayColumn)   '   Multiply the last row of the column by the TotalPermutations total thus far
    Next                                                                                    ' Loop back
'
    ReDim ResultsArray(1 To MaxRowsPerColumn, 1 To 1)                                       ' Set the dimensions for ResultsArray
'
    CurrentPermutationIndex = 1                                                             ' Initialize CurrentPermutationIndex
    CurrentColumn = 1                                                                       ' Initialize CurrentColumn
    PermutationString = ""                                                                  ' Initialize PermutationString
'
    GeneratePermutationsRecursive ArrayRow, delim, CurrentColumn, DataArray, _
            ArrayOfLastRowsOfDataColumns, PermutationString, MaxRowsPerColumn, _
            TotalPermutations, ResultsArray, ResultsRange, CurrentPermutationIndex          ' Pass variables to the recursive routine to generate the permutations
'
    If ArrayRow > 1 Then                                                                    ' If there are any remaining permutations to display then ...
        ResultsRange.Offset(0, WorksheetFunction.RoundUp(((CurrentPermutationIndex - 1) / _
                MaxRowsPerColumn), 0) - 1).Resize(ArrayRow).Value2 = ResultsArray           '   Display the remaining permutations
    End If
'
    Columns(NumberOfDataColumns + 2).CurrentRegion.Columns.AutoFit                          ' AutoFit result columns
'
    Debug.Print "Script completed in " & Timer - StartTime & " seconds."                    ' Display the completion time to the 'Immediate' window (CTRL+G) in the VBE
    MsgBox "Script completed in " & Timer - StartTime & " seconds."                         ' Display completion time in a pop-up box to the user
End Sub

Sub GeneratePermutationsRecursive(ByRef ArrayRow As Long, ByRef delim As String, _
    ByRef CurrentColumn As Long, ByRef DataArray() As Variant, _
    ByRef ArrayOfLastRowsOfDataColumns() As Long, ByVal PermutationString As String, _
    ByVal MaxRowsPerColumn As Long, ByVal TotalPermutations As Long, _
    ByRef ResultsArray() As String, ByRef ResultsRange As Range, ByRef CurrentPermutationIndex As Long)
'
    Dim i           As Long
    Dim NextValue   As String
'
    For i = 1 To ArrayOfLastRowsOfDataColumns(CurrentColumn)                                ' Loop through all columns of the ArrayOfLastRowsOfDataColumns
        If CurrentPermutationIndex > TotalPermutations Then                                 '   If we have generated all permutations then ...
            Exit Sub                                                                        '       Stop generating permutations once all are generated
        End If
'
        NextValue = DataArray(i, CurrentColumn)                                             '   Get the NextValue to be saved to the PermutationString
'
        PermutationString = PermutationString & NextValue & delim                           '   Append the NextValue & delim to PermutationString
'
        If CurrentColumn = UBound(ArrayOfLastRowsOfDataColumns) Then                        '   If we have completed a permutation then ..
            ArrayRow = ArrayRow + 1                                                         '       Increment ArrayRow
'
            If delim = "" Then                                                              '       If there is a delim set then
                ResultsArray(ArrayRow, 1) = PermutationString                               '           Save the PermutationString to ResultsArray
            Else                                                                            '       Else ...
                ResultsArray(ArrayRow, 1) = Left$(PermutationString, Len(PermutationString) - 1) '      Save the PermutationString to ResultsArray minus the trailing delim
            End If
'
            CurrentPermutationIndex = CurrentPermutationIndex + 1                           '       Increment CurrentPermutationIndex
'
            If ArrayRow = MaxRowsPerColumn Then                                             '       If we have reached the maximum size for ResultsArray then ...
                ResultsRange.Offset(0, WorksheetFunction.RoundUp(((CurrentPermutationIndex - 1) _
                        / MaxRowsPerColumn), 0) - 1).Resize(ArrayRow).Value2 = ResultsArray '           Display ResultsArray to the sheet
                ArrayRow = 0                                                                '           Reset ArrayRow
                Erase ResultsArray                                                          '
                ReDim ResultsArray(1 To MaxRowsPerColumn, 1 To 1)                           '           Set the dimensions for ResultsArray
            End If
        Else                                                                                '   Else ...
            GeneratePermutationsRecursive ArrayRow, delim, CurrentColumn + 1, DataArray, _
                ArrayOfLastRowsOfDataColumns, PermutationString, MaxRowsPerColumn, _
                TotalPermutations, ResultsArray, ResultsRange, CurrentPermutationIndex      '       Pass variables to the recursive routine to generate the permutations
        End If
'
        PermutationString = Left(PermutationString, Len(PermutationString) - _
                (Len(NextValue) + Len(delim)))                                              '   Remove the last value
    Next                                                                                    ' Loop back
End Sub


That produces 2,217,600 Permutations in about 4 to 4.5 seconds on my setup
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Scraping data from WIFI networks that are available
10 11 12
Replies
110
Views
8K
yereverluvinunclebert
Y
M
  • Solved
Need help modify to pick any first number of my choice
Replies
6
Views
605
motilulla
M
E
  • Question Question
Converting a macro to UDF
Replies
0
Views
498
excelNewbie22
E
E
  • Question Question
ignoring blanks in a macro range
Replies
4
Views
543
excelNewbie22
E
E
  • Question Question
adjusting a macro "generating combinations by a range"
Replies
3
Views
912
excelNewbie22
E

Forum statistics

Threads
1,224,814
Messages
6,181,124
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top