Все возможные комбинации от 1 до 9 в одних и тех же ячейках без повторов

Question

Как способ улучшить мое понимание VBA, я пытаюсь построить решатель перекрестных сумм.Кросс-сумма, для тех, кто не знает, быть ниже.Каждая пустая ячейка может содержать число от 1 до 9, но число может быть в сетке только один раз, и все суммы должны быть согласованы.

I 'у нас есть некоторый код с вложенными операторами for и if, который вносит все возможные вариации в ячейки, но это занимает вечность, и я уверен, что это крайне неэффективный способ сделать это.

Sub Test()
 Dim StartTime As Double
 Dim SecondsElapsed As Double

 StartTime = Timer

 Dim wb As Workbook
 Dim ws As Worksheet

 Set wb = ThisWorkbook
 Set ws = wb.Worksheets("Sheet1")

 Application.ScreenUpdating = False

 Dim i, j, k, l, m, n, o, p, q As Integer

 For i = 1 To 9
  ws.Range("A1").Value = i

  For j = 1 To 9
   If j <> ws.Range("A1").Value Then
    ws.Range("C1").Value = j
   End If

   For k = 1 To 9
    If k <> ws.Range("A1").Value Then
     If k <> ws.Range("C1").Value Then
      ws.Range("E1").Value = k
     End If
    End If

    For l = 1 To 9
     If l <> ws.Range("A1").Value Then
      If l <> ws.Range("C1").Value Then
       If l <> ws.Range("E1").Value Then
        ws.Range("A3").Value = l
       End If
      End If
     End If

     For m = 1 To 9
      If m <> ws.Range("A1").Value Then
       If m <> ws.Range("C1").Value Then
        If m <> ws.Range("E1").Value Then
         If m <> ws.Range("A3").Value Then
          ws.Range("B3").Value = m
         End If
        End If
       End If
      End If

      For n = 1 To 9
       If n <> ws.Range("A1").Value Then
        If n <> ws.Range("C1").Value Then
         If n <> ws.Range("E1").Value Then
          If n <> ws.Range("A3").Value Then
           If n <> ws.Range("C3").Value Then
            ws.Range("E3").Value = n
           End If
          End If
         End If
        End If
       End If

       For o = 1 To 9
        If o <> ws.Range("A1").Value Then
         If o <> ws.Range("C1").Value Then
          If o <> ws.Range("E1").Value Then
           If o <> ws.Range("A3").Value Then
            If o <> ws.Range("C3").Value Then
             If o <> ws.Range("E3").Value Then
              ws.Range("A5").Value = o
             End If
            End If
           End If
          End If
         End If
        End If

        For p = 1 To 9
         If p <> ws.Range("A1").Value Then
          If p <> ws.Range("C1").Value Then
           If p <> ws.Range("E1").Value Then
            If p <> ws.Range("A3").Value Then
             If p <> ws.Range("C3").Value Then
              If p <> ws.Range("E3").Value Then
               If p <> ws.Range("A3").Value Then
                ws.Range("C5").Value = p
               End If
              End If
             End If
            End If
           End If
          End If
         End If

         For q = 1 To 9
          If q <> ws.Range("A1").Value Then
           If q <> ws.Range("C1").Value Then
            If q <> ws.Range("E1").Value Then
             If q <> ws.Range("A3").Value Then
              If q <> ws.Range("C3").Value Then
               If q <> ws.Range("E3").Value Then
                If q <> ws.Range("A5").Value Then
                 If q <> ws.Range("C5").Value Then
                  ws.Range("E5").Value = q
                 End If
                End If
               End If
              End If
             End If
            End If
           End If
          End If
         Next q
        Next p
       Next o
      Next n
     Next m
    Next l
   Next k
  Next j
 Next i

 Application.ScreenUpdating = True

 SecondsElapsed = Round(Timer - StartTime, 2)

 MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

Есть либолее разумный способ добиться помещения чисел в ячейки?У меня есть часть оценки для выполнения сумм, зависящих от операторов и ответа, который уже работает, поэтому, как только я получу эту работу, я не буду каждый раз помещать ее в ячейку, а просто передаю переменную.Я просто помещаю значение в ячейку ради тестирования.

Большое спасибо

Answer 1

Метод грубой силы, который обрабатывает головоломку в памяти, требует 588.03 Seconds(s) для обработки вашей головоломки и 212.79 Seconds(s) для этой головоломки . Мой игровой компьютер, вероятно, будет обрабатывать меньше половины времени.

Sub SolveCrossSum()
    Dim t As Double: t = Timer

    Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long, n7 As Long, n8 As Long, n9 As Long
    Dim Data() As Variant
    Dim result As String

    With Worksheets("Sheet3")
        Data = .Range("A1:G7").Value
        For n1 = 1 To 9
            For n2 = 1 To 9
                For n3 = 1 To 9
                    For n4 = 1 To 9
                        For n5 = 1 To 9
                            For n6 = 1 To 9
                                For n7 = 1 To 9
                                    For n8 = 1 To 9
                                        For n9 = 1 To 9
                                            If Solved(Data, t, n1, n2, n3, n4, n5, n6, n7, n8, n9) Then
                                                .Range("A1:E5").Value = Data
                                                Debug.Print "Cross Sum was solved in: "; Round((Timer - t), 2); " Seconds(s)"
                                                Exit Sub
                                            End If
                                        Next
                                    Next
                                Next
                            Next
                        Next
                    Next
                Next
            Next
        Next
    End With
    Debug.Print "No Answer Found for Cross Sum.  Execution Time: "; Round((Timer - t) / 60, 2); " Minutes(s)"
    Debug.Print n1, n2, n3, n4, n5, n6, n7, n8, n9
End Sub


Function Solved(ByRef Data() As Variant, t As Double, n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long, n7 As Long, n8 As Long, n9 As Long) As Boolean
    If hasDuplicates(n1, n2, n3, n4, n5, n6, n7, n8, n9) Then Exit Function

    If ev(ev(n1, n2, Data(1, 2)), n3, Data(1, 4)) <> Data(1, 7) Then Exit Function
    If ev(ev(n4, n5, Data(3, 2)), n6, Data(3, 4)) <> Data(3, 7) Then Exit Function
    If ev(ev(n7, n8, Data(5, 2)), n9, Data(5, 4)) <> Data(5, 7) Then Exit Function

    If ev(ev(n1, n4, Data(2, 1)), n7, Data(4, 1)) <> Data(7, 1) Then Exit Function
    If ev(ev(n2, n5, Data(2, 3)), n8, Data(4, 3)) <> Data(7, 3) Then Exit Function
    If ev(ev(n3, n6, Data(2, 5)), n9, Data(4, 5)) <> Data(7, 5) Then Exit Function

    Data(1, 1) = n1
    Data(1, 3) = n2
    Data(1, 5) = n3
    Data(3, 1) = n4
    Data(3, 3) = n5
    Data(3, 5) = n6
    Data(5, 1) = n7
    Data(5, 3) = n8
    Data(5, 5) = n9
    Solved = True
End Function

Function ev(v1 As Long, v2 As Long, operator As Variant) As Long
    Select Case operator
        Case "+"
            ev = v1 + v2
        Case "-"
            ev = v1 - v2
        Case "/"
            ev = v1 / v2
        Case "*"
            ev = v1 * v2
    End Select
End Function

Function hasDuplicates(ParamArray Args() As Variant) As Boolean
    Dim n1 As Long, n2 As Long
    For n1 = 0 To UBound(Args)
        If Args(n1) = 10 Then Exit Function
        For n2 = 0 To UBound(Args)
            If n1 <> n2 Then
                If Args(n1) = Args(n2) Then
                    hasDuplicates = True
                    Exit Function
                End If
            End If
        Next
    Next
End Function

Answer 2

Вы можете поместить числа в массив - работать с массивами быстрее, чем с диапазонами, и вы можете использовать IsError(Application.Match(Value,Array,0)), чтобы проверить, использовалось ли число Value где-либо в Array.

Как только вы найдете «правильное» решение, вы можете остановить циклы (если вы не хотите проверить , сколько допустимых решений существует) - меня могут прокричать и поносить некоторые за это, но GoTo - быстрое, грязное и простое решение

Кроме того, я собираюсь использовать несколько трюков CodeGolf , чтобы сделать код визуально короче, например, используя Символы типа для упрощения операторов Dim или цепочку Next утверждение - и вместо проверки того, что вывод остается действительным после генерации каждого числа, я сделаю это один раз после генерации всех 9.

Sub CrossSumSolver()

    Dim StartTime As Double
    Dim SecondsElapsed As Double

    StartTime = Timer

    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Dim OutputArray(1 To 9) As Long, IsValid As Boolean, CheckLoop As Long
    Dim a&, b&, c&, d&, e&, f&, g&, h&, i& 'All "As Long"

    For a = 1 To 9
        OutputArray(1) = a
        For b = 1 To 9
            OutputArray(2) = b
            For c = 1 To 9
                OutputArray(3) = c
                For d = 1 To 9
                    OutputArray(4) = d
                    For e = 1 To 9
                        OutputArray(5) = e
                        For f = 1 To 9
                            OutputArray(6) = f
                            For g = 1 To 9
                                OutputArray(7) = g
                                For h = 1 To 9
                                    OutputArray(8) = h
                                    For i = 1 To 9
                                        OutputArray(9) = i
                                        'Array is populated - is it valid?
                                        IsValid = True
                                        'Are all 9 numbers used once?
                                        For CheckLoop = 1 To 9
                                            If IsError(Application.Match(CheckLoop, OutputArray, 0)) Then
                                                IsValid = False 'A number is missing!
                                                Exit For 'Only need to find 1 error
                                            End If
                                        Next CheckLoop
                                        If IsValid Then
                                            'Populate sheet
                                            ws.Range("A1").Value = OutputArray(1)
                                            ws.Range("C1").Value = OutputArray(2)
                                            ws.Range("E1").Value = OutputArray(3)
                                            ws.Range("A3").Value = OutputArray(4)
                                            ws.Range("C3").Value = OutputArray(5)
                                            ws.Range("E3").Value = OutputArray(6)
                                            ws.Range("A5").Value = OutputArray(7)
                                            ws.Range("C5").Value = OutputArray(8)
                                            ws.Range("E5").Value = OutputArray(9)
                                            'Calculate sheet
                                            ws.Calculate
                                            'Check if your output is correct
                                            If (False) Then GoTo QuickExit 'Replace (False) with your check!
                                        End If
    Next i, h, g, f, e, d, c, b, a 'No need for a Wall of "Next"

QuickExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    SecondsElapsed = Round(Timer - StartTime, 2)

    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

В качестве альтернативы, вы можете использовать зло рекурсивной подпрограммы (то есть подпрограммы, которая вызывает себя) для циклического перебора чисел для каждого элемента в массиве по очереди. (Мощный при правильном использовании, но поймите неправильно, и в итоге ваш компьютер будет заблокирован в постоянном цикле, а Excel / VBA потребляет все больше и больше памяти)

Option Explicit

Private ValueArray(1 To 9) As Long
Private wb As Workbook
Private ws As Worksheet

Public Sub ControlLoop()
    Dim StartTime As Double
    Dim SecondsElapsed As Double

    StartTime = Timer

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Dim OutermostLoop As Long

    For OutermostLoop = 1 To 9
        ClearArrayAbove 1
        RecursiveArrayLoop 1, OutermostLoop
    Next OutermostLoop

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    SecondsElapsed = Round(Timer - StartTime, 2)

    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

Private Sub ClearArrayAbove(ArrayItem As Long)
    If ArrayItem >= 9 Then Exit Sub 'Safety check
    Dim InnerLoop As Long

    For InnerLoop = ArrayItem To 9
        ValueArray(InnerLoop) = 0
    Next InnerLoop
End Sub

Private Sub RecursiveArrayLoop(ArrayItem As Long, NewValue As Long)
    Dim InnerLoop As Long

    'Number is not already in the array
    If IsError(Application.Match(NewValue, ValueArray, 0)) Then
        'Add number to array
        ValueArray(ArrayItem) = NewValue
        If ArrayItem < 9 Then
            'Go up a level, and loop again
            For InnerLoop = 1 To 9
                ClearArrayAbove ArrayItem
                RecursiveArrayLoop ArrayItem + 1, InnerLoop
            Next InnerLoop
        Else
            'All numbers filled!
            TestValidNumbers
        End If
    End If
End Sub

Private Sub TestValidNumbers()
    'Populate sheet
    ws.Range("A1").Value = ValueArray(1)
    ws.Range("C1").Value = ValueArray(2)
    ws.Range("E1").Value = ValueArray(3)
    ws.Range("A3").Value = ValueArray(4)
    ws.Range("C3").Value = ValueArray(5)
    ws.Range("E3").Value = ValueArray(6)
    ws.Range("A5").Value = ValueArray(7)
    ws.Range("C5").Value = ValueArray(8)
    ws.Range("E5").Value = ValueArray(9)
    'Calculate sheet
    ws.Calculate
    'Check if your output is correct
    'Do stuff here?
End Sub

Answer 3

Я бы посоветовал вам следующий способ решения такой проблемы:
Дайте переменным несколько ясных имен, таких как a1, a2, ..., следующим образом:

first row  :  a1  a2  a3
second row :  b1  b2  b3
third row  :  c1  c2  c3

Ваш алгоритм может выглядеть следующим образом (псевдокод):

for a1 = 0 to 9:
  for a2 = 0 to 9:
    if (a1 <> a2) // all have to be different
    then:
      for a3 = 0 to 9:
      if ((a1 <> a3) and (a2 <> a3)) and // all have to be different
         (a1 - a2 / a3 = 1)              // start checking if the first row is correct,
                                         // otherwise it makes no sense to continue.
      then:
      ...

Удачи

Answer 4

Чтобы сгенерировать случайную перестановку цифр от 1 до 9 без повторов , выберите ячейку, скажем G1 и введите:

=RANDBETWEEN(1,9)

, затем в G2 введите:

=LARGE(IF(ISNA(MATCH({1;2;3;4;5;6;7;8;9},G$1:G1,0)),{1;2;3;4;5;6;7;8;9}),RANDBETWEEN(1,9-ROWS(G$2:G2)))

и скопируйте вниз.

Каждый раз при пересчете листабудет вычислена новая перестановка.

После заполнения столбца его можно отобразить в любой прямоугольный массив с формулами, такими как:

=G1