Permutations - Macro

Question

Hi All,

I need some help composing a Macro.

I'll outline the steps needed to be done and I'll appreciate if anyone can put this into code.

Although for the example given below (2,9,4,7,5,3,6,1,8) there might be more simpler ways to get the results, for the case where this will applied I'll need to follow the steps below.

• For numbers 1-9
• Get all permutations for 3 digit combinations using number 1-9 (no duplicates)
• Filter only those combinations that total 15 (2,9,4,7,5,3,6,1,8)
• Add three more digits to all possible permutations (no duplicates, including first 3 digits) (2,9,4,7,5,3,6,1,8)
• Filter out only those that second three digits also equal 15 (2,9,4,7,5,3,6,1,8)
• Add one more digit to all possible permutations (no duplicates, including first 6 digits) (2,9,4,7,5,3,6,1,8)
• Filter our only those permutations that 1st, 4th and 7th digit equal 15 (2,9,4,7,5,3,6,1,8)
• Filter our only those permutations that 3rd, 5th and 7th digit equal 15 (2,9,4,7,5,3,6,1,8)
• Add one more digit to all possible permutations (no duplicates, including first 7 digits) (2,9,4,7,5,3,6,1,8)
• Filter our only those permutations that 2nd, 5th and 8th digit equal 15 (2,9,4,7,5,3,6,1,8)
• Add one more digit to all possible permutations (no duplicates, including first 8 digits) (2,9,4,7,5,3,6,1,8)
• Filter our only those permutations that 3rd, 6th and 9th digit equal 15 (2,9,4,7,5,3,6,1,8)
• Filter our only those permutations that 1st, 5th and 9th digit equal 15 (2,9,4,7,5,3,6,1,8)
• Export all possible permutations to excel

Thanks in advance

Uncle Bear

Answer 1

To create a macro that generates permutations of the numbers 1-9 and filters them based on your specified criteria, you can use the following VBA code as a starting point. This code will handle the generation of permutations, filtering based on the sum of digits, and exporting the results to Excel.

Sub GeneratePermutations()
    Dim numbers As Variant
    Dim results As Collection
    Dim perm As Variant
    Dim i As Long, j As Long
    Dim total As Long
    Dim outputRow As Long

    ' Initialize numbers and results collection
    numbers = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
    Set results = New Collection

    ' Generate permutations of 3 digits
    Call Permute(numbers, 3, results)

    ' Filter results for combinations that total 15
    For Each perm In results
        total = 0
        For i = 0 To 2
            total = total + perm(i)
        Next i
        If total = 15 Then
            ' Add additional digits and filter further
            Call AddAndFilter(perm, numbers, results)
        End If
    Next perm

    ' Export results to Excel
    outputRow = 1
    For Each perm In results
        Cells(outputRow, 1).Value = Join(perm, ", ")
        outputRow = outputRow + 1
    Next perm
End Sub

Sub Permute(arr As Variant, n As Long, ByRef results As Collection)
    Dim i As Long, j As Long
    Dim temp As Variant
    Dim current As Variant

    If n = 1 Then
        results.Add arr
    Else
        For i = 0 To n - 1
            Call Permute(arr, n - 1, results)
            If n Mod 2 = 0 Then
                temp = arr(i)
                arr(i) = arr(n - 1)
                arr(n - 1) = temp
            Else
                temp = arr(0)
                arr(0) = arr(n - 1)
                arr(n - 1) = temp
            End If
        Next i
    End If
End Sub

Sub AddAndFilter(perm As Variant, numbers As Variant, ByRef results As Collection)
    ' Implementation to add digits and filter based on your criteria
    ' This will require additional logic similar to the filtering done above
End Sub

This code provides a basic structure for generating permutations and filtering them based on the sum of the first three digits. You will need to implement the AddAndFilter subroutine to handle the additional filtering steps as outlined in your request. The results will be exported to the active Excel sheet.

---

References:

• Add a Unique List of Values to a Combo Box
• Getting started with VBA in Office

Answer 2

Hi @Uncle Bear,

Thank you for posting your question in the Microsoft Q&A forum.

I greatly appreciate your detailed information. According to your request, you can try using this VBA script by pressing Alt + F11 to open VBA editor > Insert > Module:

Option Explicit
 
Sub GenerateMagicSquares_FromSheetRange()
    Dim wsSrc As Worksheet
    Dim rng As Range, v As Variant
    Dim Numbers As Variant
    Dim TargetSum As Double
    Dim i As Long
 
    ' --- Source range: Sheet1!A1:A9 ---
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")
    Set rng = wsSrc.Range("A1:A9") 'Change the sheet name and range with your current worksheet
    v = rng.Value
 
    If rng.Rows.Count <> 9 Then
        MsgBox "Please provide exactly 9 cells in Sheet1!A1:A9.", vbExclamation
        Exit Sub
    End If
 
    ReDim Numbers(0 To 8)
    For i = 1 To 9
        If IsEmpty(v(i, 1)) Or Not IsNumeric(v(i, 1)) Then
            MsgBox "Cell " & rng.Cells(i, 1).Address(False, False) & _
                   " is empty or not numeric. Please enter 9 numbers.", vbExclamation
            Exit Sub
        End If
        Numbers(i - 1) = CDbl(v(i, 1))
    Next i
 
    If Not AreAllDistinct(Numbers) Then
        MsgBox "All 9 numbers in Sheet1!A1:A9 must be distinct.", vbExclamation
        Exit Sub
    End If
 
    TargetSum = 3 * AverageOfArray(Numbers)
 
    ' Optional: Warn if TargetSum isn't an integer (if you want decimals you can enable this part by delete the ')
    ' If TargetSum <> Int(TargetSum) Then
    '     If MsgBox("Target sum is non-integer (" & TargetSum & "). Continue?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    ' End If
 
    Dim used() As Boolean: ReDim used(0 To UBound(Numbers))
    Dim pos(1 To 9) As Double
    Dim results As Collection: Set results = New Collection
 
    BacktrackFillGeneric 1, pos, used, Numbers, TargetSum, results
    WriteResultsToSheet_Generic results, TargetSum
 
    MsgBox "Done. Found " & results.Count & " solution(s). Target sum = " & TargetSum, vbInformation
End Sub
 
Private Function AreAllDistinct(arr As Variant) As Boolean
    Dim i As Long, j As Long
    For i = LBound(arr) To UBound(arr)
        For j = i + 1 To UBound(arr)
            If arr(i) = arr(j) Then
                AreAllDistinct = False
                Exit Function
            End If
        Next j
    Next i
    AreAllDistinct = True
End Function
 
Private Function AverageOfArray(arr As Variant) As Double
    Dim i As Long, sum As Double
    For i = LBound(arr) To UBound(arr)
        sum = sum + arr(i)
    Next i
    AverageOfArray = sum / (UBound(arr) - LBound(arr) + 1)
End Function
Private Sub BacktrackFillGeneric(ByVal i As Integer, _
                                 ByRef pos() As Double, _
                                 ByRef used() As Boolean, _
                                 ByRef Numbers As Variant, _
                                 ByVal TargetSum As Double, _
                                 ByRef results As Collection)
    Dim idx As Long
    Dim ok As Boolean
 
    For idx = LBound(Numbers) To UBound(Numbers)
        If Not used(idx) Then
            pos(i) = Numbers(idx)
            used(idx) = True
 
            ok = True
            Select Case i
                Case 3
                    ok = (pos(1) + pos(2) + pos(3) = TargetSum)
                Case 6
                    ok = (pos(4) + pos(5) + pos(6) = TargetSum)
                Case 7
                    ok = (pos(1) + pos(4) + pos(7) = TargetSum) _
                         And (pos(3) + pos(5) + pos(7) = TargetSum)
                Case 8
                    ok = (pos(2) + pos(5) + pos(8) = TargetSum)
                Case 9
                    ok = (pos(3) + pos(6) + pos(9) = TargetSum) _
                         And (pos(1) + pos(5) + pos(9) = TargetSum)
                    ok = ok And (pos(7) + pos(8) + pos(9) = TargetSum) ' row 3
            End Select
 
            If ok Then
                If i = 9 Then
                    Dim s As String, k As Integer
                    For k = 1 To 9
                        s = s & FormatNumberForCsv(pos(k))
                        If k < 9 Then s = s & ","
                    Next k
                    results.Add s
                Else
                    BacktrackFillGeneric i + 1, pos, used, Numbers, TargetSum, results
                End If
            End If
 
            used(idx) = False
        End If
    Next idx
End Sub
 
Private Function FormatNumberForCsv(ByVal v As Double) As String
    If v = Int(v) Then
        FormatNumberForCsv = CStr(CLng(v))
    Else
        FormatNumberForCsv = CStr(v)
    End If
End Function
 
Private Sub WriteResultsToSheet_Generic(ByRef results As Collection, ByVal TargetSum As Double)
    Dim ws As Worksheet
    Dim i As Long, rowOut As Long
    Dim tokens() As String
 
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets("PermutationsResult")
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = "PermutationsResult"
    Else
        ws.Cells.Clear
    End If
 
    ws.Range("B1").Value = "Positions 1..9 (Row-wise)"
    ws.Range("K1").Value = "3×3 Grid View"
    ws.Range("M1").Offset(0, 1).Value = "Target Sum:"
    ws.Range("M1").Offset(0, 2).Value = TargetSum
 
    rowOut = 2
    For i = 1 To results.Count
        tokens = Split(CStr(results(i)), ",")
 
        ws.Cells(rowOut, "B").Resize(1, 9).Value = tokens
 
        ws.Cells(rowOut, "K").Resize(1, 3).Value = Array(tokens(0), tokens(1), tokens(2))
        ws.Cells(rowOut + 1, "K").Resize(1, 3).Value = Array(tokens(3), tokens(4), tokens(5))
        ws.Cells(rowOut + 2, "K").Resize(1, 3).Value = Array(tokens(6), tokens(7), tokens(8))
 
               rowOut = rowOut + 4
    Next i
 
    ws.Columns("B:J").AutoFit
    ws.Columns("K:M").ColumnWidth = 4
 
End Sub

The number input in my Excel worksheet is Sheet 1 cell A1 to A9. After that, press Alt + F8 to run the VBA script.

Since I'm using Magic Square mathematical concept so the result will be displayed like this:

Hope this information will help. Please follow these steps and let me know if it works for you. If not, we can work together to resolve this.    

Thank you for your patience and your understanding. If you have any questions or need further assistance, please feel free to share them in the comments so I can continue to support you. 

I look forward to your response.

---

If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment".     

Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread. 

Answer 3

Thanks for this macro!!!

I did like that you output the answers in grids.

Before I try to decode this line by line. Can this macro be considerably shortened.

Additionally, I would remove the message boxes etc. and rely on the fact that the use case would be almost identical to this macro.

Thanks!!!!!!

Answer 4

Hi @Uncle Bear,

Thank you for your response.

If you want a shorten version, you can try this script. This script removes no message boxes, no formatting, only calculation and results:

Sub GenerateMagicSquares()
    Dim v As Variant, Numbers(0 To 8) As Double, TargetSum As Double
    Dim i As Long, used(0 To 8) As Boolean, pos(1 To 9) As Double
    Dim results As Collection: Set results = New Collection
    Dim ws As Worksheet: Set ws = Sheets("Sheet1")
    v = ws.Range("A1:A9").Value
    For i = 1 To 9: Numbers(i - 1) = CDbl(v(i, 1)): Next i
    TargetSum = 3 * (WorksheetFunction.sum(Numbers) / 9)
 
    BacktrackSame 1, pos, used, Numbers, TargetSum, results
 
    ws.Columns("D:E").ClearContents
 
    Dim rowOut As Long, tokens() As String
    rowOut = 1
    For i = 1 To results.Count
        tokens = Split(results(i), ",")
        ws.Cells(rowOut, "D").Resize(1, 3).Value = Array(tokens(0), tokens(1), tokens(2))
        ws.Cells(rowOut + 1, "D").Resize(1, 3).Value = Array(tokens(3), tokens(4), tokens(5))
        ws.Cells(rowOut + 2, "D").Resize(1, 3).Value = Array(tokens(6), tokens(7), tokens(8))
        rowOut = rowOut + 4
    Next i
End Sub
 
Private Sub BacktrackSame(ByVal idx As Integer, pos() As Double, used() As Boolean, Numbers() As Double, TargetSum As Double, results As Collection)
    Dim n As Long, ok As Boolean
    For n = 0 To 8
        If Not used(n) Then
            pos(idx) = Numbers(n): used(n) = True
            ok = True
            Select Case idx
                Case 3: ok = (pos(1) + pos(2) + pos(3) = TargetSum)
                Case 6: ok = (pos(4) + pos(5) + pos(6) = TargetSum)
                Case 7: ok = (pos(1) + pos(4) + pos(7) = TargetSum) And (pos(3) + pos(5) + pos(7) = TargetSum)
                Case 8: ok = (pos(2) + pos(5) + pos(8) = TargetSum)
                Case 9: ok = (pos(3) + pos(6) + pos(9) = TargetSum) And (pos(1) + pos(5) + pos(9) = TargetSum) And (pos(7) + pos(8) + pos(9) = TargetSum)
            End Select
            If ok Then
                If idx = 9 Then
                    Dim s As String, k As Integer
                    For k = 1 To 9: s = s & pos(k) & IIf(k < 9, ",", ""): Next k
                    results.Add s
                Else
                    BacktrackSame idx + 1, pos, used, Numbers, TargetSum, results
                End If
            End If
            used(n) = False
        End If
    Next n
End Sub

In case you want the results show as rows, you can try this one instead:

Sub GenerateMagicSquares_SingleLine()
    Dim v As Variant, Numbers(0 To 8) As Double, TargetSum As Double
    Dim i As Long, used(0 To 8) As Boolean, pos(1 To 9) As Double
    Dim results As Collection: Set results = New Collection
    Dim ws As Worksheet: Set ws = Sheets("Sheet1")
    v = ws.Range("A1:A9").Value
    For i = 1 To 9: Numbers(i - 1) = CDbl(v(i, 1)): Next i
    TargetSum = 3 * (WorksheetFunction.sum(Numbers) / 9)
    BacktrackSingle 1, pos, used, Numbers, TargetSum, results
 
    ws.Range("D:L").ClearContents
    Dim rowOut As Long, tokens() As String
    rowOut = 1
    For i = 1 To results.Count
        tokens = Split(results(i), ",")
        ws.Cells(rowOut, "D").Resize(1, 9).Value = tokens
        rowOut = rowOut + 2
    Next i
End Sub
 
Private Sub BacktrackSingle(ByVal idx As Integer, pos() As Double, used() As Boolean, Numbers() As Double, TargetSum As Double, results As Collection)
    Dim n As Long, ok As Boolean
    For n = 0 To 8
        If Not used(n) Then
            pos(idx) = Numbers(n): used(n) = True
            ok = True
            Select Case idx
                Case 3: ok = (pos(1) + pos(2) + pos(3) = TargetSum)
                Case 6: ok = (pos(4) + pos(5) + pos(6) = TargetSum)
                Case 7: ok = (pos(1) + pos(4) + pos(7) = TargetSum) And (pos(3) + pos(5) + pos(7) = TargetSum)
                Case 8: ok = (pos(2) + pos(5) + pos(8) = TargetSum)
                Case 9: ok = (pos(3) + pos(6) + pos(9) = TargetSum) And (pos(1) + pos(5) + pos(9) = TargetSum) And (pos(7) + pos(8) + pos(9) = TargetSum)
            End Select
            If ok Then
                If idx = 9 Then
                    Dim s As String, k As Integer
                    For k = 1 To 9: s = s & pos(k) & IIf(k < 9, ",", ""): Next k
                    results.Add s
                Else
                        BacktrackSingle idx + 1, pos, used, Numbers, TargetSum, results
                End If
            End If
            used(n) = False
        End If
    Next n
 
End Sub

Hope this will help. Please feel free to reach out again if you need any help. I will be happy to assist you.

Looking forward to your response.