Modify a code to run all possible combinations

[tony0217]

I have a code below that runs all possible combinations for as many columns as i have in sheet 1.
the problem is that if i have a certain number of cells that would create more than 1,048,000 (excel line limit) different permutations, then the code will stop even though there could be more permutations to calculate.

Can anyone modify this code to continue over to column B and so on so that all possible permutations can be created?

thank you.

Sub Permute()
Dim ix(100, 1) As Long, rc As Long, m As Long, br As Long, md As Variant, i As Long, r As Long
Dim str1 As String

    rc = Cells(1, Columns.Count).End(xlToLeft).Column
    m = 0
    For i = 1 To rc
        br = Cells(Rows.Count, i).End(xlUp).Row
        If br > m Then m = br
        ix(i, 0) = br
        ix(i, 1) = 1
    Next i
    md = Range(Cells(1, 1), Cells(m, rc)).Value

    r = 0
Incr:
    str1 = ""
    For i = 1 To rc
        str1 = str1 & md(ix(i, 1), i)
    Next i
    r = r + 1
    Sheets("Sheet2").Cells(r, "A") = str1
    
    For i = rc To 1 Step -1
        ix(i, 1) = ix(i, 1) + 1
        If ix(i, 1) <= ix(i, 0) Then Exit For
        ix(i, 1) = 1
    Next i
    If i > 0 Then GoTo Incr:
    
End Sub

 

[Eric W]

Wow, that looks like one of my macros. Nice to see it still has legs.

First off, I really don't see any reason to print out so many permutations. What use will you have for them? There's too many to eyeball for any particular reason, and if you have another macro analyze them, you can save a lot of time by not saving them at all, just analyze them within the macro.

Nevertheless, if you want it to continue to the next column, try:

Sub Permute()
Dim ix(100, 1) As Long, rc As Long, m As Long, br As Long, md As Variant, i As Long, r As Long
Dim str1 As String, r1 As Long, c1 As Long

    rc = Cells(1, Columns.Count).End(xlToLeft).Column
    m = 0
    For i = 1 To rc
        br = Cells(Rows.Count, i).End(xlUp).Row
        If br > m Then m = br
        ix(i, 0) = br
        ix(i, 1) = 1
    Next i
    md = Range(Cells(1, 1), Cells(m, rc)).Value

    r = 0
Incr:
    str1 = ""
    For i = 1 To rc
        str1 = str1 & md(ix(i, 1), i)
    Next i
    r = r + 1
    r1 = ((r - 1) Mod Rows.Count) + 1
    c1 = Int((r - 1) / Rows.Count) + 1
    Sheets("Sheet2").Cells(r1, c1) = str1
    
    For i = rc To 1 Step -1
        ix(i, 1) = ix(i, 1) + 1
        If ix(i, 1) <= ix(i, 0) Then Exit For
        ix(i, 1) = 1
    Next i
    If i > 0 Then GoTo Incr:
    
End Sub

If you want a different row, say 1,000,000 to end on, instead of the number of rows, just use that number in place of Rows.count that I marked in red.

Hope this helps.

 

[tony0217]

It is a very fine piece of code indeed. Thanks for creating it!
It seems you had a point about there being alot of space being taken up for no reason.
I ran the code and there would have been well over 1 billion rows of space taken up.

I have a question.
Instead of having a code write out every single permutation,
Is there a way to modify this code to perform 'My Code' in between permutations?

Basically, I have to analyze each permutation, and i only want to keep the ones that match a certain criteria.
out of the billion or so permutations i only expect that about 100k would be kept.

Is there a way to figure permutation #1 , analyze permutation #1 , Run 'My Code' and then move on to the next permutation?

If so, could you please show in the code where I would place 'My Code' in the macro?

Thank you again!

 

[Eric W]

Ah, that makes more sense!

Sub Permute()
Dim ix(100, 1) As Long, rc As Long, m As Long, br As Long, md As Variant, i As Long, r As Long
Dim str1 As String, r1 As Long, c1 As Long
    rc = Cells(1, Columns.Count).End(xlToLeft).Column
    m = 0
    For i = 1 To rc
        br = Cells(Rows.Count, i).End(xlUp).Row
        If br > m Then m = br
        ix(i, 0) = br
        ix(i, 1) = 1
    Next i
    md = Range(Cells(1, 1), Cells(m, rc)).Value
    r = 0
Incr:
    str1 = ""
    For i = 1 To rc
        str1 = str1 & md(ix(i, 1), i)
    Next I

MyCode:

    r = r + 1
    r1 = ((r - 1) Mod Rows.Count) + 1
    c1 = Int((r - 1) / Rows.Count) + 1
    Sheets("Sheet2").Cells(r1, c1) = str1
    
    For i = rc To 1 Step -1
        ix(i, 1) = ix(i, 1) + 1
        If ix(i, 1) <= ix(i, 0) Then Exit For
        ix(i, 1) = 1
    Next i
    If i > 0 Then GoTo Incr:
    
End Sub

The part in red is what generates each combination. After that, you can analyze str1 to see if it matches your criteria, where I put the MyCode: label. The part in blue is what actually puts it on the sheet. If you don't want to save that particular combination, just skip the blue part and continue with the next black line, which is where the indexes are incremented.

Good luck!

 

[tony0217]

looks like what i need, but not sure how to use it.
Do i just place my vba code on the line that says MyCode:?

 

[tony0217]

This is basically what im trying to do between permutations. and at the end of MyCode, i'd like to say if column R value is TRUETRUETRUE, Then copy and paste to the next available row on page 3.

Sub Macro1()'
' Macro1 Macro
'


'
    Range("A4:F22").Select
    Selection.ClearContents
    Columns("B:F").Select
    Selection.Cut Destination:=Columns("C:G")
    Columns("D:G").Select
    Selection.Cut Destination:=Columns("E:H")
    Columns("F:H").Select
    Selection.Cut Destination:=Columns("G:I")
    Columns("H:I").Select
    Selection.Cut Destination:=Columns("I:J")
    Columns("J:J").Select
    Selection.Cut Destination:=Columns("K:K")
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Columns("C:C").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Columns("E:E").Select
    Selection.TextToColumns Destination:=Range("E1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Columns("G:G").Select
    Selection.TextToColumns Destination:=Range("G1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Columns("I:I").Select
    Selection.TextToColumns Destination:=Range("I1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Columns("K:K").Select
    Selection.TextToColumns Destination:=Range("K1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1)), TrailingMinusNumbers:=True
    Range("A1:L3").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "=EXACT(RC[-13],RC[-11])"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "=EXACT(RC[-14],RC[-10])"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "=EXACT(RC[-13],RC[-11])"
    Range("N1:P1").Select
    Selection.Copy
    Range("R1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-4],RC[-3],RC[-2])"
    Range("R2").Select
End Sub

 

[Eric W]

First off, it appears that you're using the Macro Recorder to create some VBA code. That's an excellent idea, you can learn a lot that way. However, code from the recorder can be cleaned up quite a bit both for efficiency and readability. Check out this article:

The Next Step Beyond the Macro Recorder in VBA Programming | | InformIT

Next, when you read/write a lot to a worksheet, it takes time (point #10 in that article). When we write hundreds of thousands of lines, it adds up a lot. So it's usually best to analyze the data in the macro before writing it. Looking at your code, it appears you're splitting the combinations back into their component parts, then comparing them with something, then recombining them, all using worksheet functions. All that can be done in VBA, much quicker.

I haven't quite figured out what logic you use to decide if you keep a combination. Can you explain it in regular English?

 

[tony0217]

ok, no problem.

I have a list of items that i need to make a list out of.
for example i have 3 columns of data (or more).
each cell in the range A1-C5 has 2 letters ex. AB, NN, MJ. which i separate using text to columns. They then look like this A B N N M J in the range A1-F1.
I then compare cells A1 WITH C1, B1 WITH D1, AND C1 WITH E1. In the range N1-P1. N1 has the A1-C1, O1 has the B1-D1 and P1 has the C1-E1 comparison. the comparison will read TRUE TRUE TRUE in cells N, O and P.
I then concatenate columns N-P in column R.
which then leaves TRUETRUETRUE or TRUEFALSEFALSE for example in column R.
I only want to keep the permutation and row if the value IS EQUAL TO TRUETRUETRUE.
if the value of R is equal to TRUETRUETRUE, then copy and paste the entire row to the next available row on sheet 3.
after the copy and paste, I'd like to do the same thing with the next permutation.

that sounds about right lol

 

[Eric W]

Gosh, where to start?

OK, your method of comparing the 3 values is a bit convoluted. Based on what you said, the first comparison checks the first character of the first value (AB) with the first character of the second value, and the second comparison compares the second character of each. In other words, you're using 2 comparisons to see if A1 = B1. This can be done in one step without text-to-columns "=A1=B1". The third comparison checks the first character of the second value with the first character of the third value, or "=LEFT(B1,1)=LEFT(C1,1)". You can even combine those comparisons like so: "=AND(A1=B1,LEFT(B1,1)=LEFT(C1,1))". So a single formula instead of text-to-columns, then 3 comparisons, then concatenate. I gather that this is just an example, but if your requirements consist of checking parts of the values against each other, then you can always do that with a combination of LEFT, MID, RIGHT, or other worksheet functions.

All of these functions have VBA equivalents. Given these requirements, you could change the macro to this:

Sub Permute()
Dim ix(100, 1) As Long, rc As Long, m As Long, br As Long, md As Variant, i As Long, r As Long
Dim str1 As String, r1 As Long, c1 As Long


    rc = Cells(1, Columns.Count).End(xlToLeft).Column
    m = 0
    For i = 1 To rc
        br = Cells(Rows.Count, i).End(xlUp).Row
        If br > m Then m = br
        ix(i, 0) = br
        ix(i, 1) = 1
    Next i
    md = Range(Cells(1, 1), Cells(m, rc)).Value
    r = 0
Incr:
    str1 = ""
    For i = 1 To rc
        str1 = str1 & md(ix(i, 1), i)
    Next i


MyCode:
    If md(ix(1, 1), 1) = md(ix(2, 1), 2) And Left(md(ix(2, 1), 2), 1) = Left(md(ix(3, 1), 3), 1) Then

        r = r + 1
        r1 = ((r - 1) Mod Rows.Count) + 1
        c1 = Int((r - 1) / Rows.Count) + 1
        Sheets("Sheet2").Cells(r1, c1) = str1
    End If
    
    For i = rc To 1 Step -1
        ix(i, 1) = ix(i, 1) + 1
        If ix(i, 1) <= ix(i, 0) Then Exit For
        ix(i, 1) = 1
    Next i
    If i > 0 Then GoTo Incr:
    
End Sub

and it would only display the combinations matching your description. The component from each column is referenced by md(ix(n, 1), n) where n is the column number. Upon rereading the code again, it's a bit opaque. I'd probably rename some things and put some comments in if I were to do it again. But you can use the components in the macro to decide which ones to keep.

Make sense, or did I just muddy the waters?

 

[tony0217]

yo YOU ARE A GENIUS!
this is exactly what ive been looking for.

One last thing?

could you just show me how to scale it to add more columns into the picture. like maybe up to 10 columns wide?
thank you!