Attribute VB_Name = "Module1"
Option Explicit

Public Const nCells As Integer = 13
Public Const nDigits As Integer = 9
Public Const answerRow As Integer = nCells + 8
Public Const maxAnswers As Long = 12000000
Public req(nDigits) As Boolean

Dim idxCntA As Long
Dim cntA As Long
Dim answers(maxAnswers, nCells) As Integer
Dim bAllowDupes As Boolean

Sub Button1_Click() ' show possibilities
    Dim r As Long, c As Long ' r - row, c - column
    Dim x As Long, y As Long
    Dim i As Long, j As Long, k As Long
    Dim cntUsedCells As Integer
    Dim val  As Integer, sumVal As Integer
    Dim x1 As Integer, x2 As Integer, x3 As Integer, x4 As Integer, x5 As Integer, x6 As Integer
    Dim x7 As Integer, x8 As Integer, x9 As Integer, x10 As Integer, x11 As Integer, x12 As Integer, x13 As Integer
    Dim pc As Long
    Dim cell As Long
    Dim cnt(nCells) As Long
    Dim uses(nCells) As Long
    Dim vals(nCells, nDigits) As Integer ' holds the numbers entered
    Dim bValUsed(nCells, nCells) As Boolean ' holds the numbers entered
    Dim total As Integer
    Dim cntReqNum As Integer
    Dim bAndReq As Boolean
    Dim bUsed(nDigits) As Boolean
    
    Dim bSaveAnswer As Boolean, bHasDupes As Boolean, bHasReqNums As Boolean
    Dim aryVals(nCells) As Integer
    
    Dim bDelAnswer(maxAnswers) As Boolean
    Dim bResetAnsArray As Boolean
    Dim tmpAnswers(maxAnswers, nCells) As Integer
    Dim idxNArray As Long

    Dim hr As Integer, mn As Integer ' for saving workbook
    Dim MyTime
    Dim strFileName As String

    Dim ws As Worksheet
    Set ws = ActiveSheet

    'Application.ScreenUpdating = False
    'Application.Calculation = xlManual
    Application.DisplayAlerts = False

    For r = 1 To nCells ' remove old use markers - nCells is last row of inputs. Remove background red only
        For c = 2 To nDigits + 1
            ws.Cells(r, c).Interior.Color = xlNone
        Next c
    Next r
    Button2_Click (1) ' remove answers

    ' make sure a total is entered
    If IsEmpty(ws.Cells(nCells + 1, 2).Value) = True Then
        Exit Sub
    End If
    total = ws.Cells(nCells + 1, 2)
    
    ' allow dupes?
    If IsEmpty(ws.Cells(nCells + 1, 8).Value) = True Then
        bAllowDupes = False
    Else
        bAllowDupes = True
    End If
    
    ' AND the req nums?
    If IsEmpty(ws.Cells(nCells + 3, 12).Value) = True Then
        bAndReq = False
    Else
        bAndReq = True
    End If
    
    ' get count of required numbers
    cntReqNum = 0
    For k = 1 To nDigits
        If req(k) Then
            cntReqNum = cntReqNum + 1
        End If
    Next k
    
    ' read in values entered
    For r = 1 To nCells
        For c = 2 To nDigits + 1
            If Not IsEmpty(ws.Cells(r, c).Value) = True Then
                vals(r, cnt(r)) = ws.Cells(r, c)
                cnt(r) = cnt(r) + 1
            End If
        Next c
    Next r
    
    For r = 1 To nCells
        If cnt(r) = 0 Then
            cntUsedCells = r - 1
            Exit For
        End If
        If r = nCells Then
            cntUsedCells = nCells
        End If
    Next r
    
    For r = 1 To nCells
        If cnt(r) = 0 Then
            cnt(r) = 1
        End If
    Next r
    
    cntA = 0
    
    For x1 = 0 To cnt(1) - 1
        For x2 = 0 To cnt(2) - 1
            For x3 = 0 To cnt(3) - 1
                For x4 = 0 To cnt(4) - 1
                    For x5 = 0 To cnt(5) - 1
                        For x6 = 0 To cnt(6) - 1
                            For x7 = 0 To cnt(7) - 1
                                For x8 = 0 To cnt(8) - 1
                                    For x9 = 0 To cnt(9) - 1
                                        For x10 = 0 To cnt(10) - 1
                                            For x11 = 0 To cnt(11) - 1
                                                For x12 = 0 To cnt(12) - 1
                                                    For x13 = 0 To cnt(13) - 1
                                                        sumVal = vals(1, x1) + vals(2, x2) + vals(3, x3) + vals(4, x4) + vals(5, x5) + vals(6, x6) + vals(7, x7) + vals(8, x8) + vals(9, x9) + vals(10, x10) + vals(11, x11) + vals(12, x12) + vals(13, x13)
                                                        If sumVal = total Then
                                                            bSaveAnswer = True
                                                            
                                                            aryVals(1) = vals(1, x1)
                                                            aryVals(2) = vals(2, x2)
                                                            aryVals(3) = vals(3, x3)
                                                            aryVals(4) = vals(4, x4)
                                                            aryVals(5) = vals(5, x5)
                                                            aryVals(6) = vals(6, x6)
                                                            aryVals(7) = vals(7, x7)
                                                            aryVals(8) = vals(8, x8)
                                                            aryVals(9) = vals(9, x9)
                                                            aryVals(10) = vals(10, x10)
                                                            aryVals(11) = vals(11, x11)
                                                            aryVals(12) = vals(12, x12)
                                                            aryVals(13) = vals(13, x13)
        
                                                            ' test for dupes if not allowed
                                                            If Not bAllowDupes Then
                                                                bHasDupes = checkForDupes(aryVals)
                                                                If bHasDupes Then
                                                                    bSaveAnswer = False
                                                                End If
                                                            End If
                                                            
                                                            ' test for required numbers if needed
                                                            If cntReqNum > 0 Then
                                                                bHasReqNums = checkForReqNums(aryVals, cntReqNum, bAndReq)
                                                                If Not bHasReqNums Then
                                                                    bSaveAnswer = False
                                                                End If
                                                            End If
                                                            
                                                            If bSaveAnswer Then
                                                                answers(cntA, 1) = vals(1, x1)
                                                                answers(cntA, 2) = vals(2, x2)
                                                                answers(cntA, 3) = vals(3, x3)
                                                                answers(cntA, 4) = vals(4, x4)
                                                                answers(cntA, 5) = vals(5, x5)
                                                                answers(cntA, 6) = vals(6, x6)
                                                                answers(cntA, 7) = vals(7, x7)
                                                                answers(cntA, 8) = vals(8, x8)
                                                                answers(cntA, 9) = vals(9, x9)
                                                                answers(cntA, 10) = vals(10, x10)
                                                                answers(cntA, 11) = vals(11, x11)
                                                                answers(cntA, 12) = vals(12, x12)
                                                                answers(cntA, 13) = vals(13, x13)
                                                                cntA = cntA + 1
                                                                
                                                                If cntA = maxAnswers Then GoTo ToManyPoss
                                                            End If
                                                        End If
                                                    Next x13
                                                Next x12
                                            Next x11
                                        Next x10
                                    Next x9
                                Next x8
                            Next x7
                        Next x6
                    Next x5
                Next x4
            Next x3
        Next x2
    Next x1
    
    cntA = cntA - 1 ' get rid of final/extra count
    
    ' count uses and figure out which numbers are used
    For idxCntA = 0 To cntA
        Erase bUsed
        For j = 1 To nCells
            If answers(idxCntA, j) > 0 Then
                val = answers(idxCntA, j) ' index
                bValUsed(j, val) = True
                If Not bUsed(val) Then
                    uses(val) = uses(val) + 1
                    bUsed(val) = True
                End If
            End If
        Next j
    Next idxCntA
    
    ' display the answers
    
    If cntA < 500 Then
        pc = 2
        For idxCntA = 0 To cntA
            For r = 1 To nCells
                If answers(idxCntA, r) > 0 Then
                    ws.Cells(answerRow + r - 1, pc) = answers(idxCntA, r)
                End If
            Next r
            pc = pc + 1
        Next idxCntA
    Else
        Const maxRowSmall As Long = 500000
        Dim sc As Integer, lRow As Long
        Dim sheetsNeeded As Integer
        Dim lastRow As Long, lastCol As Long
        Dim tSheet As Worksheet
        Dim newBook As Workbook
    
        lastRow = cntA
        lastCol = cntUsedCells
        
        sheetsNeeded = 1 + Int(lastRow / maxRowSmall)
        Application.SheetsInNewWorkbook = sheetsNeeded
        Set newBook = Workbooks.Add
        
        For sc = 1 To sheetsNeeded
            Set tSheet = newBook.Sheets("Sheet" & CStr(sc))
            ReDim arySmall(0 To maxRowSmall - 1, 1 To lastCol)
    
            For c = 1 To lastCol
                tSheet.Cells(1, c) = "Cell " & CStr(c)
                tSheet.Columns(c).ColumnWidth = 5
                tSheet.Columns(c).HorizontalAlignment = Excel.Constants.xlCenter
            Next c
            
            For r = 0 To maxRowSmall - 1
                lRow = r + (sc - 1) * maxRowSmall
                If lRow > lastRow Then Exit For
                
                For c = 1 To lastCol
                    arySmall(r, c) = answers(lRow, c)
                Next c
            Next r
            
            tSheet.Cells(2, 1).Resize(UBound(arySmall), UBound(arySmall, 2)) = arySmall
        Next sc
        
        ' save the wb
        MyTime = Time
        hr = Hour(MyTime)
        mn = Minute(MyTime)
        strFileName = "C:\Users\Gerry\Desktop\Book_" & Format(hr, "00") & Format(mn, "00")
        newBook.SaveAs strFileName
        Set newBook = Nothing
    End If

    ' display the uses
    For r = 1 To nCells
        For c = 2 To nDigits + 1
            val = ws.Cells(r, c)
            If bValUsed(r, val) Then
                ws.Cells(r, c).Interior.ColorIndex = 3
            End If
        Next c
    Next r
    
    ' display the counts
    ws.Cells(answerRow + nCells + 1, 2).Value = cntA + 1
    For r = 1 To nDigits
        ws.Cells(r + answerRow + nCells + 1, 2) = uses(r)
    Next r
    
    ' cleanup
ToManyPoss:
    Erase answers
    Erase cnt
    Erase uses
    Erase vals
    Erase bValUsed
    Erase bUsed
    Erase aryVals
    Erase bDelAnswer
    Erase tmpAnswers
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub

Private Function checkForDupes(ByRef values() As Integer) As Boolean
    Dim i As Integer, j As Integer
    
    For i = 1 To nCells
        For j = i + 1 To nCells
            If (values(i) <> 0 Or values(j) <> 0) And values(i) = values(j) Then
                checkForDupes = True
                Exit Function
            End If
        Next j
    Next i
    
    checkForDupes = False
End Function

Private Function checkForReqNums(ByRef values() As Integer, ByRef cntReqNum As Integer, bAndReq As Boolean) As Boolean
    Dim i As Integer, j As Integer
    Dim bAryVals(nDigits) As Boolean
    Dim cntMatch As Integer

    For i = 1 To nCells
        bAryVals(values(i)) = True
    Next i

    For i = 1 To nDigits
        If bAryVals(i) And req(i) Then
            cntMatch = cntMatch + 1
        End If
    Next i

    If Not bAndReq And cntMatch >= 1 Then
        checkForReqNums = True
    ElseIf cntMatch = cntReqNum Then
        checkForReqNums = True
    Else
        checkForReqNums = False
    End If
    
    Erase bAryVals
End Function