数独をExcelのVBAで解くのをやってみた

0.README.md

[Excel] VBAで数独を解くのをやってみた

はけた氏のツイート経由で、

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1｜VBAサンプル集

を見て、面白そうだったので、自分なりに書き下してみた。

→ GitHub上で「ExcelSudoku」としてクラスモジュール化したものを公開中。

001-sudoku-history.vba

' [数独をExcelのVBAで解くのをやってみた](https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1)

Option Explicit

Private Const ScreenUpdate As Boolean = False ' True: 画面更新

Private TryCounter As Long ' 試行回数

' 行列←→グループ座標変換用
Private GroupMapInitialized As Boolean
Private PositionToGroupMap(1 To 9, 1 To 9) As Variant
Private GroupToPositionMap(1 To 9, 1 To 9) As Variant

' ビット演算用
Private BitOperationInitialized As Boolean
Private Bit() As Long
Private BitAll As Long
Private BitmapToLength() As Long
Private BitmapToNumberValues() As String

' 試行履歴用
Type RemainNumberInfo
    NumberValuesBitMap As Long
End Type

Type MapInfo
    RemainNumberMap(1 To 9, 1 To 9) As RemainNumberInfo
End Type

Type SudokuHistoryItem
    RowNumber As Long
    ColumnNumber As Long
    NumberValue As Long
    MapInfo As MapInfo
End Type

Private SudokuHistoryLength As Long
Private SudokuHistory(0 To 81) As SudokuHistoryItem

Sub main()
    Dim NumberMatrix() As Long
    Dim SudokuRange As Range
    Dim SudokuResult As Boolean
    Dim StartTime As Double
    Dim EndTime As Double
    Dim ElapsedTimeString As String
    
    Call InitializeBitOperation
    Call InitializeGroupMap
    
    Set SudokuRange = Range("A1:I9")
    
    ' 数独問題初期化＆妥当性チェック
    If Not ResetSudokuRange(SudokuRange, NumberMatrix) Then
        MsgBox "不正な問題"
        Exit Sub
    End If
    
    Range("G10").Value = ""
    Range("C10").Value = ""

    StartTime = Timer
    Debug.Print StartTime
    
    ' 数独解読処理
    TryCounter = 0
    SudokuResult = TrySudoku(SudokuRange, NumberMatrix)
    
    EndTime = Timer
    If EndTime < StartTime Then EndTime = EndTime + 24 * 60 * 60
    Debug.Print EndTime
    ElapsedTimeString = Format((EndTime - StartTime), "0.0000")
    Debug.Print "結果: " & TryCounter & "回試行・" & ElapsedTimeString & "秒経過"
    
    ' 結果出力
    SudokuRange.Value = NumberMatrix
    Range("C10").Value = TryCounter
    Range("G10").Value = ElapsedTimeString
    
    ' 数独回答チェック
    If CheckSudokuMatrix(NumberMatrix) = 0 Then
        MsgBox "解読成功" & vbLf & TryCounter
    Else
        MsgBox "あれれ…？"
    End If
End Sub

Function ResetSudokuRange(ByRef SudokuRange As Range, ByRef NumberMatrix() As Long) As Boolean
    Application.ScreenUpdating = False

    Dim SudokuRangeValues As Variant
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    
    ReDim NumberMatrix(1 To 9, 1 To 9)
    
    SudokuRangeValues = SudokuRange.Value
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If SudokuRangeValues(RowNumber, ColumnNumber) = 0 Or Cells(RowNumber, ColumnNumber).Font.Color = vbBlue Then
                NumberMatrix(RowNumber, ColumnNumber) = 0
                Cells(RowNumber, ColumnNumber).Value = ""
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlue
            Else
                NumberMatrix(RowNumber, ColumnNumber) = Cells(RowNumber, ColumnNumber).Value
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlack
            End If
            Cells(RowNumber, ColumnNumber).Interior.ColorIndex = xlNone
        Next ColumnNumber
    Next RowNumber
    
    If 0 <= CheckSudokuMatrix(NumberMatrix) Then
        ResetSudokuRange = True
    Else
        ResetSudokuRange = False
    End If
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Function

Function CheckSudokuMatrix(ByRef NumberMatrix() As Long) As Long
    Dim RowNumberValueCounters(1 To 9, 1 To 9) As Long
    Dim ColumnNumberValueCounters(1 To 9, 1 To 9) As Long
    Dim GroupNumberValueCounters(1 To 9, 1 To 9) As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim SetNumberValue As Long
        
    CheckSudokuMatrix = 81
    ReDim ErrorInfos(0)
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            SetNumberValue = NumberMatrix(RowNumber, ColumnNumber)
            If SetNumberValue <> 0 Then
                Call PositionToGroup(RowNumber, ColumnNumber, GroupNumber, GroupItemNumber)
                RowNumberValueCounters(RowNumber, SetNumberValue) = RowNumberValueCounters(RowNumber, SetNumberValue) + 1
                ColumnNumberValueCounters(ColumnNumber, SetNumberValue) = ColumnNumberValueCounters(ColumnNumber, SetNumberValue) + 1
                GroupNumberValueCounters(GroupNumber, SetNumberValue) = GroupNumberValueCounters(GroupNumber, SetNumberValue) + 1
            End If
        Next ColumnNumber
    Next RowNumber
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            SetNumberValue = NumberMatrix(RowNumber, ColumnNumber)
            If SetNumberValue <> 0 Then
                Call PositionToGroup(RowNumber, ColumnNumber, GroupNumber, GroupItemNumber)
                
                If _
                    1 < RowNumberValueCounters(RowNumber, SetNumberValue) Or _
                    1 < ColumnNumberValueCounters(ColumnNumber, SetNumberValue) Or _
                    1 < GroupNumberValueCounters(GroupNumber, SetNumberValue) _
                Then
                    ReDim Preserve ErrorInfos(UBound(ErrorInfos) + 1)
                    ErrorInfos(UBound(ErrorInfos)) = Array(RowNumber, ColumnNumber)
                Else
                    CheckSudokuMatrix = CheckSudokuMatrix - 1
                End If
            End If
        Next ColumnNumber
    Next RowNumber
    
    If UBound(ErrorInfos) <= 0 Then
        Exit Function
    End If
    
    CheckSudokuMatrix = -1
    For ErrorIndex = 1 To UBound(ErrorInfos)
        Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Interior.Color = vbRed
    Next ErrorIndex
End Function

Function TrySudoku(ByRef SudokuRange As Range, ByRef NumberMatrix() As Long) As Boolean
    Call InitializeBitOperation
    Call InitializeGroupMap
    
    Call InitializeSudokuMatrix(SudokuRange, NumberMatrix)
    TrySudoku = TrySudokuMatrix(NumberMatrix)
End Function

Sub InitializeSudokuMatrix(ByRef SudokuRangeValues As Variant, ByRef NumberMatrix() As Long)
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim NumberValue As Long
    
    SudokuHistoryLength = 0
    With SudokuHistory(SudokuHistoryLength)
        For RowNumber = 1 To 9
            For ColumnNumber = 1 To 9
                With .MapInfo.RemainNumberMap(RowNumber, ColumnNumber)
                    .NumberValuesBitMap = BitAll
                End With
            Next ColumnNumber
        Next RowNumber
    End With
    
    ReDim NumberMatrix(1 To 9, 1 To 9)

    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            NumberValue = SudokuRangeValues(RowNumber, ColumnNumber)
            If NumberValue <> 0 Then
                Call PushSudokuHistory(NumberMatrix, RowNumber, ColumnNumber, NumberValue)
            End If
        Next ColumnNumber
    Next RowNumber
End Sub

Function TrySudokuMatrix(ByRef NumberMatrix() As Long) As Boolean
    Dim BackupSudokuHistoryLength As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim MinNumberLength As Long
    Dim NumberValues As String
    Dim NumberLength As Long
    Dim TryRowNumber As Long
    Dim TryColumnNumber As Long
    Dim TryNumberValues As String
    Dim TryNumberLength As Long
    Dim Index As Long
    
    If ScreenUpdate Then Range("A1:I9").Value = NumberMatrix
    
    TryCounter = TryCounter + 1
    
    If 81 <= SudokuHistoryLength Then
        TrySudokuMatrix = True
        Exit Function
    End If
        
    BackupSudokuHistoryLength = SudokuHistoryLength
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                With SudokuHistory(SudokuHistoryLength).MapInfo.RemainNumberMap(RowNumber, ColumnNumber)
                    NumberLength = BitmapToLength(.NumberValuesBitMap)
                    If NumberLength = 1 Then
                        Call PushSudokuHistory(NumberMatrix, RowNumber, ColumnNumber, CLng(BitmapToNumberValues(.NumberValuesBitMap)))
                        
                        If 81 <= SudokuHistoryLength Then
                            TrySudokuMatrix = True
                            Exit Function
                        End If
                    End If
                End With
            End If
        Next ColumnNumber
    Next RowNumber
    
    MinNumberLength = 10
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                With SudokuHistory(SudokuHistoryLength).MapInfo.RemainNumberMap(RowNumber, ColumnNumber)
                    NumberLength = BitmapToLength(.NumberValuesBitMap)
                    If NumberLength < MinNumberLength Then
                        TryRowNumber = RowNumber
                        TryColumnNumber = ColumnNumber
                        MinNumberLength = NumberLength
                    End If
                End With
            End If
        Next ColumnNumber
    Next RowNumber

    If MinNumberLength < 10 Then
        With SudokuHistory(SudokuHistoryLength).MapInfo.RemainNumberMap(TryRowNumber, TryColumnNumber)
            TryNumberLength = BitmapToLength(.NumberValuesBitMap)
            TryNumberValues = BitmapToNumberValues(.NumberValuesBitMap)
        End With
        
        For Index = 1 To TryNumberLength
            Call PushSudokuHistory(NumberMatrix, TryRowNumber, TryColumnNumber, CLng(Mid(TryNumberValues, Index, 1)))
            
            If TrySudokuMatrix(NumberMatrix) Then
                TrySudokuMatrix = True
                Exit Function
            End If
            
            Call PopSudokuHistory(NumberMatrix)
        Next
    End If
    
    Do While BackupSudokuHistoryLength < SudokuHistoryLength
        Call PopSudokuHistory(NumberMatrix)
    Loop

    TrySudokuMatrix = False
End Function

Sub PushSudokuHistory(ByRef NumberMatrix() As Long, ByRef SetRowNumber As Long, ByRef SetColumnNumber As Long, ByRef SetNumberValue As Long)
    Dim SetGroupNumber As Long
    Dim SetGroupItemNumber As Long
    Dim CheckRowNumber As Long
    Dim CheckColumnNumber As Long
    Dim CheckGroupItemNumber As Long
    
    NumberMatrix(SetRowNumber, SetColumnNumber) = SetNumberValue
    
    SudokuHistoryLength = SudokuHistoryLength + 1
    With SudokuHistory(SudokuHistoryLength)
        .RowNumber = SetRowNumber
        .ColumnNumber = SetColumnNumber
        .NumberValue = SetNumberValue
        .MapInfo = SudokuHistory(SudokuHistoryLength - 1).MapInfo
        
        With .MapInfo.RemainNumberMap(SetRowNumber, SetColumnNumber)
            .NumberValuesBitMap = 0
        End With
        
        Call PositionToGroup(SetRowNumber, SetColumnNumber, SetGroupNumber, SetGroupItemNumber)
        
        For CheckRowNumber = 1 To 9
            If CheckRowNumber <> SetRowNumber Then
                With .MapInfo.RemainNumberMap(CheckRowNumber, SetColumnNumber)
                    .NumberValuesBitMap = BitOff(.NumberValuesBitMap, SetNumberValue)
                End With
            End If
        Next
        
        For CheckColumnNumber = 1 To 9
            If CheckColumnNumber <> SetColumnNumber Then
                With .MapInfo.RemainNumberMap(SetRowNumber, CheckColumnNumber)
                    .NumberValuesBitMap = BitOff(.NumberValuesBitMap, SetNumberValue)
                End With
            End If
        Next
        
        For CheckGroupItemNumber = 1 To 9
            If CheckGroupItemNumber <> SetGroupItemNumber Then
                Call GroupToPosition(SetGroupNumber, CheckGroupItemNumber, CheckRowNumber, CheckColumnNumber)
                With .MapInfo.RemainNumberMap(CheckRowNumber, CheckColumnNumber)
                    .NumberValuesBitMap = BitOff(.NumberValuesBitMap, SetNumberValue)
                End With
            End If
        Next
    End With
End Sub

Sub PopSudokuHistory(ByRef NumberMatrix() As Long)
    With SudokuHistory(SudokuHistoryLength)
        NumberMatrix(.RowNumber, .ColumnNumber) = 0
    End With
    
    SudokuHistoryLength = SudokuHistoryLength - 1
End Sub

Private Sub InitializeBitOperation(Optional ByRef MaxNumberValue = 9)
    If BitOperationInitialized Then Exit Sub
    
    Dim NumberValue As Long
    Dim BitIndex As Long
    Dim Index As Long
    
    BitAll = 0
    ReDim Bit(1 To MaxNumberValue)
    
    For NumberValue = 1 To MaxNumberValue
        Bit(NumberValue) = 2 ^ (NumberValue - 1)
        BitAll = BitOn(BitAll, NumberValue)
    Next

    ReDim BitmapToLength(0 To BitAll)
    ReDim BitmapToNumberValues(0 To BitAll)
    
    BitmapToLength(0) = 0
    BitmapToNumberValues(0) = ""
    
    For NumberValue = 1 To MaxNumberValue
        BitIndex = Bit(NumberValue)
        
        For Index = 0 To BitIndex - 1
            BitmapToLength(BitIndex + Index) = BitmapToLength(Index) + 1
            BitmapToNumberValues(BitIndex + Index) = BitmapToNumberValues(Index) & NumberValue
        Next Index
    Next NumberValue
    
    BitOperationInitialized = True
End Sub

Function BitOn(ByRef BitMap As Long, ByRef NumberValue As Long) As Long
    BitOn = BitMap Or Bit(NumberValue)
End Function

Function BitOff(ByRef BitMap As Long, ByRef NumberValue As Long) As Long
    BitOff = BitMap And (Not Bit(NumberValue))
End Function

Private Sub InitializeGroupMap()
    If GroupMapInitialized Then Exit Sub
    
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            Call CalcPositionToGroup(RowNumber, ColumnNumber, GroupNumber, GroupItemNumber)
            PositionToGroupMap(RowNumber, ColumnNumber) = Array(GroupNumber, GroupItemNumber)
        Next ColumnNumber
    Next RowNumber
    
    For GroupNumber = 1 To 9
        For GroupItemNumber = 1 To 9
            Call CalcGroupToPosition(GroupNumber, GroupItemNumber, RowNumber, ColumnNumber)
            GroupToPositionMap(GroupNumber, GroupItemNumber) = Array(RowNumber, ColumnNumber)
        Next GroupItemNumber
    Next GroupNumber
    
    GroupMapInitialized = True
End Sub

Sub PositionToGroup(ByRef RowNumber As Long, ByRef ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = PositionToGroupMap(RowNumber, ColumnNumber)(0)
    GroupItemNumber = PositionToGroupMap(RowNumber, ColumnNumber)(1)
End Sub

Sub GroupToPosition(ByRef GroupNumber As Long, ByRef GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(0)
    ColumnNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(1)
End Sub

Sub CalcPositionToGroup(ByRef RowNumber As Long, ByRef ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = Fix((RowNumber + 2) / 3) + 3 * (Fix((ColumnNumber + 2) / 3) - 1)
    GroupItemNumber = 1 + ((RowNumber + 2) Mod 3) + 3 * ((ColumnNumber + 2) Mod 3)
End Sub

Sub CalcGroupToPosition(ByRef GroupNumber As Long, ByRef GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = 1 + 3 * ((GroupNumber - 1) Mod 3) + ((GroupItemNumber - 1) Mod 3)
    ColumnNumber = 1 + 3 * Fix((GroupNumber - 1) / 3) + Fix((GroupItemNumber - 1) / 3)
End Sub

002-sudoku-flag.vba

Option Explicit

Private Const ScreenUpdate As Boolean = False

Private TryCounter As Long

' 行／列／グループ（枠）それぞれの内に数字が存在するかどうかをフラグで管理
Private Bit(1 To 9) As Long
Private RowFlags(1 To 9) As Long
Private ColumnFlags(1 To 9) As Long
Private GroupFlags(1 To 9) As Long

' 行列←→グループ座標変換用
Private PositionToGroupMap(1 To 9, 1 To 9) As Variant
Private GroupToPositionMap(1 To 9, 1 To 9) As Variant


Sub main()
    Dim NumberMatrix() As Long
    Dim StartTime As Double
    Dim EndTime As Double
    Dim ElapsedTimeString As String
    
    TryCounter = 0
    
    If Not InitSudoku(NumberMatrix) Then
        MsgBox "不正な問題"
        Exit Sub
    End If

    Range("H10").Value = ""
    Range("C10").Value = ""

    StartTime = Timer
    Debug.Print StartTime
    
    TrySudoku NumberMatrix
    
    EndTime = Timer
    Debug.Print EndTime
  
    Range("A1:I9").Value = NumberMatrix
    
    ElapsedTimeString = Format((EndTime - StartTime), "0.00")
    Debug.Print "ビット演算使用版: " & TryCounter & "回試行・" & ElapsedTimeString & "秒経過"
    
    Range("C10").Value = TryCounter
    Range("H10").Value = ElapsedTimeString
    
    If CheckNumberMatrix(NumberMatrix) = 0 Then
        MsgBox "解読成功" & vbLf & TryCounter
    Else
        MsgBox "あれれ・・・"
    End If
End Sub

Function InitSudoku(ByRef NumberMatrix() As Long) As Boolean
    Application.ScreenUpdating = False
    
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim SourceValueArray() As Variant
    Dim RemainBlankNumber As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    InitSudoku = True
    
    ReDim NumberMatrix(1 To 9, 1 To 9)
    
    SourceValueArray = Range("A1:I9").Value
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If SourceValueArray(RowNumber, ColumnNumber) = 0 Or Cells(RowNumber, ColumnNumber).Font.Color = vbBlue Then
                Cells(RowNumber, ColumnNumber).Value = ""
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlue
            Else
                NumberMatrix(RowNumber, ColumnNumber) = Cells(RowNumber, ColumnNumber).Value
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlack
            End If
        Next ColumnNumber
    Next RowNumber
    
    RemainBlankNumber = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If 0 < UBound(ErrorInfos) Then
        For ErrorIndex = 1 To UBound(ErrorInfos)
            Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
            Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
        Next ErrorIndex
        
        InitSudoku = False
    End If

    Application.CutCopyMode = False
    Range("A10").Select
    
    Application.ScreenUpdating = True
End Function

Function TrySudoku(ByRef NumberMatrix() As Long) As Boolean
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim Index As Long
    Dim RemainNumbers() As Long
    Dim TryNumber As Long

    If Not GetBlankPosition(NumberMatrix, RowNumber, ColumnNumber, RemainNumbers) Then
        TrySudoku = True
        Exit Function
    End If

    For Index = 1 To UBound(RemainNumbers)
        TryNumber = RemainNumbers(Index)
        
        UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, TryNumber
        If ScreenUpdate Then Cells(RowNumber, ColumnNumber) = TryNumber
                
        TryCounter = TryCounter + 1
        
        If TrySudoku(NumberMatrix) = True Then
            TrySudoku = True
            Exit Function
        End If
    Next
    
    UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, 0
    If ScreenUpdate Then
        Cells(RowNumber, ColumnNumber) = ""
        DoEvents
    End If
    TrySudoku = False
End Function

Function CheckNumberMatrix(ByRef NumberMatrix() As Long) As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    CheckNumberMatrix = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If UBound(ErrorInfos) <= 0 Then
        Exit Function
    End If
    
    CheckNumberMatrix = -1
    For ErrorIndex = 1 To UBound(ErrorInfos)
        Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
        Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
    Next ErrorIndex
End Function

Function GetBlankPosition(ByRef NumberMatrix() As Long, ByRef TargetRowNumber As Long, ByRef TargetColumnNumber As Long, ByRef RemainNumbers() As Long) As Boolean
    Dim RemainNumbersMatrix(1 To 9, 1 To 9) As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim CheckRowNumber As Long
    Dim CheckColumnNumber As Long
    Dim CheckGroupItemNumber As Long
    Dim NumberValue As Long
    Dim Point As Long
    Dim MinPoint As Long
    Dim RemainNumberCounter As Long
    Dim NumberIndex As Long
    
    TargetRowNumber = 0
    TargetColumnNumber = 0
    ReDim RemainNumbers(0)
    
    GetBlankPosition = False
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            RemainNumberCounter = 0
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For NumberValue = 1 To 9
                    If ((RowFlags(RowNumber) Or ColumnFlags(ColumnNumber) Or GroupFlags(GroupNumber)) And Bit(NumberValue)) = 0 Then
                        RemainNumberCounter = RemainNumberCounter + 1
                    End If
                Next NumberValue
            End If
            RemainNumbersMatrix(RowNumber, ColumnNumber) = RemainNumberCounter
        Next RowNumber
    Next ColumnNumber
    
    MinPoint = 9999
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                Point = 1000 * RemainNumbersMatrix(RowNumber, ColumnNumber)
                
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For CheckColumnNumber = 1 To 9
                    If CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(RowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(RowNumber, CheckColumnNumber)
                    End If
                Next
                
                For CheckRowNumber = 1 To 9
                    If CheckRowNumber <> RowNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, ColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, ColumnNumber)
                    End If
                Next
                
                For CheckGroupItemNumber = 1 To 9
                    GroupToPosition GroupNumber, CheckGroupItemNumber, CheckRowNumber, CheckColumnNumber
                    If CheckRowNumber <> RowNumber And CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber)
                    End If
                Next
                
                If Point < MinPoint Then
                    TargetRowNumber = RowNumber
                    TargetColumnNumber = ColumnNumber
                    MinPoint = Point
                End If
            End If
        Next ColumnNumber
    Next RowNumber

    If MinPoint < 9999 Then
        PositionToGroup TargetRowNumber, TargetColumnNumber, GroupNumber, GroupItemNumber
        For NumberValue = 1 To 9
            If ((RowFlags(TargetRowNumber) Or ColumnFlags(TargetColumnNumber) Or GroupFlags(GroupNumber)) And Bit(NumberValue)) = 0 Then
                ReDim Preserve RemainNumbers(UBound(RemainNumbers) + 1)
                RemainNumbers(UBound(RemainNumbers)) = NumberValue
            End If
        Next NumberValue
        
        GetBlankPosition = True
    End If
End Function

Sub UpdateNumberMatrix(ByRef NumberMatrix() As Long, ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByVal NumberValue As Long)
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim OldNumberValue As Long
    
    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
    
    OldNumberValue = NumberMatrix(RowNumber, ColumnNumber)
    
    If 0 < OldNumberValue Then
        RowFlags(RowNumber) = RowFlags(RowNumber) And (Not Bit(OldNumberValue))
        ColumnFlags(ColumnNumber) = ColumnFlags(ColumnNumber) And (Not Bit(OldNumberValue))
        GroupFlags(GroupNumber) = GroupFlags(GroupNumber) And (Not Bit(OldNumberValue))
    End If
    
    If 0 < NumberValue Then
        RowFlags(RowNumber) = RowFlags(RowNumber) Or Bit(NumberValue)
        ColumnFlags(ColumnNumber) = ColumnFlags(ColumnNumber) Or Bit(NumberValue)
        GroupFlags(GroupNumber) = GroupFlags(GroupNumber) Or Bit(NumberValue)
    End If

    NumberMatrix(RowNumber, ColumnNumber) = NumberValue
End Sub

Function InitNumberMatrix(ByRef NumberMatrix() As Long, ByRef ErrorInfos() As Variant) As Long
    ' 行／列／グループ（枠）それぞれの内に数字が存在するかどうかを疑似連想配列で管理
    ' ※フラグだけでは座標までは分からないため、初期化時のみ連想配列も併用
    Dim RowDictArray(1 To 9, 1 To 9) As Long
    Dim ColumnDictArray(1 To 9, 1 To 9) As Long
    Dim GroupDictArray(1 To 9, 1 To 9) As Long

    Dim Index As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim NumberValue As Long
    Dim ExistRowNumber As Long
    Dim ExistColumnNumber As Long
    
    InitNumberMatrix = 9 * 9
    
    ReDim ErrorInfos(0)
    
    For NumberValue = 1 To 9
        Bit(NumberValue) = 2 ^ NumberValue
    Next NumberValue
    
    For Index = 1 To 9
        RowFlags(Index) = 0
        ColumnFlags(Index) = 0
        GroupFlags(Index) = 0
        
        For NumberValue = 1 To 9
            RowDictArray(Index, NumberValue) = 0
            ColumnDictArray(Index, NumberValue) = 0
            GroupDictArray(Index, NumberValue) = 0
        Next NumberValue
    Next Index
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            CalcPositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
            PositionToGroupMap(RowNumber, ColumnNumber) = Array(GroupNumber, GroupItemNumber)
        Next RowNumber
    Next ColumnNumber
    
    For GroupNumber = 1 To 9
        For GroupItemNumber = 1 To 9
            CalcGroupToPosition GroupNumber, GroupItemNumber, RowNumber, ColumnNumber
            GroupToPositionMap(GroupNumber, GroupItemNumber) = Array(RowNumber, ColumnNumber)
        Next GroupItemNumber
    Next GroupNumber
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            NumberValue = NumberMatrix(RowNumber, ColumnNumber)

            If NumberValue <> 0 Then
                If RowDictArray(RowNumber, NumberValue) Then
                    ExistRowNumber = RowNumber
                    ExistColumnNumber = RowDictArray(RowNumber, NumberValue)
                ElseIf ColumnDictArray(ColumnNumber, NumberValue) Then
                    ExistRowNumber = ColumnDictArray(ColumnNumber, NumberValue)
                    ExistColumnNumber = ColumnNumber
                Else
                    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber

                    If GroupDictArray(GroupNumber, NumberValue) Then
                        GroupToPosition GroupNumber, GroupDictArray(GroupNumber, NumberValue), ExistRowNumber, ExistColumnNumber
                    Else
                        ExistRowNumber = 0
                        ExistColumnNumber = 0
                        
                        RowFlags(RowNumber) = RowFlags(RowNumber) Or Bit(NumberValue)
                        ColumnFlags(ColumnNumber) = ColumnFlags(ColumnNumber) Or Bit(NumberValue)
                        GroupFlags(GroupNumber) = GroupFlags(GroupNumber) Or Bit(NumberValue)

                        RowDictArray(RowNumber, NumberValue) = ColumnNumber
                        ColumnDictArray(ColumnNumber, NumberValue) = RowNumber
                        GroupDictArray(GroupNumber, NumberValue) = GroupItemNumber
                        
                        InitNumberMatrix = InitNumberMatrix - 1
                    End If
                End If

                If 0 < ExistRowNumber Then
                    ReDim Preserve ErrorInfos(UBound(ErrorInfos) + 1)
                    ErrorInfos(UBound(ErrorInfos)) = Array(RowNumber, ColumnNumber, ExistRowNumber, ExistColumnNumber, NumberValue)
                End If
            End If
        Next RowNumber
    Next ColumnNumber
End Function

Sub PositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = PositionToGroupMap(RowNumber, ColumnNumber)(0)
    GroupItemNumber = PositionToGroupMap(RowNumber, ColumnNumber)(1)
End Sub

Sub GroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(0)
    ColumnNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(1)
End Sub

Sub CalcPositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = Fix((RowNumber + 2) / 3) + 3 * (Fix((ColumnNumber + 2) / 3) - 1)
    GroupItemNumber = 1 + ((RowNumber + 2) Mod 3) + 3 * ((ColumnNumber + 2) Mod 3)
End Sub

Sub CalcGroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = 1 + 3 * ((GroupNumber - 1) Mod 3) + ((GroupItemNumber - 1) Mod 3)
    ColumnNumber = 1 + 3 * Fix((GroupNumber - 1) / 3) + Fix((GroupItemNumber - 1) / 3)
End Sub

003-sudoku-dict.vba

Option Explicit

Private Const ScreenUpdate As Boolean = False

Private TryCounter As Long

' 行／列／グループ（枠）それぞれの内に数字が存在するかどうかを疑似連想配列で管理
Private RowDictArray(1 To 9, 1 To 9) As Long
Private ColumnDictArray(1 To 9, 1 To 9) As Long
Private GroupDictArray(1 To 9, 1 To 9) As Long

' 行列←→グループ座標変換用
Private PositionToGroupMap(1 To 9, 1 To 9) As Variant
Private GroupToPositionMap(1 To 9, 1 To 9) As Variant


Sub main()
    Dim NumberMatrix() As Long
    Dim StartTime As Double
    Dim EndTime As Double
    Dim ElapsedTimeString As String
    
    TryCounter = 0
    
    If Not InitSudoku(NumberMatrix) Then
        MsgBox "不正な問題"
        Exit Sub
    End If

    Range("H10").Value = ""
    Range("C10").Value = ""

    StartTime = Timer
    Debug.Print StartTime
    
    TrySudoku NumberMatrix
    
    EndTime = Timer
    Debug.Print EndTime
  
    Range("A1:I9").Value = NumberMatrix
    
    ElapsedTimeString = Format((EndTime - StartTime), "0.00")
    Debug.Print "疑似連想配列使用版: " & TryCounter & "回試行・" & ElapsedTimeString & "秒経過"
    
    Range("C10").Value = TryCounter
    Range("H10").Value = ElapsedTimeString
    
    If CheckNumberMatrix(NumberMatrix) = 0 Then
        MsgBox "解読成功" & vbLf & TryCounter
    Else
        MsgBox "あれれ・・・"
    End If
End Sub

Function InitSudoku(ByRef NumberMatrix() As Long) As Boolean
    Application.ScreenUpdating = False
    
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim SourceValueArray() As Variant
    Dim RemainBlankNumber As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    InitSudoku = True
    
    ReDim NumberMatrix(1 To 9, 1 To 9)
    
    SourceValueArray = Range("A1:I9").Value
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If SourceValueArray(RowNumber, ColumnNumber) = 0 Or Cells(RowNumber, ColumnNumber).Font.Color = vbBlue Then
                Cells(RowNumber, ColumnNumber).Value = ""
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlue
            Else
                NumberMatrix(RowNumber, ColumnNumber) = Cells(RowNumber, ColumnNumber).Value
                Cells(RowNumber, ColumnNumber).Font.Color = vbBlack
            End If
        Next ColumnNumber
    Next RowNumber
    
    RemainBlankNumber = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If 0 < UBound(ErrorInfos) Then
        For ErrorIndex = 1 To UBound(ErrorInfos)
            Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
            Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
        Next ErrorIndex
        
        InitSudoku = False
    End If

    Application.CutCopyMode = False
    Range("A10").Select
    
    Application.ScreenUpdating = True
End Function

Function TrySudoku(ByRef NumberMatrix() As Long) As Boolean
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim Index As Long
    Dim RemainNumbers() As Long
    Dim TryNumber As Long

    If Not GetBlankPosition(NumberMatrix, RowNumber, ColumnNumber, RemainNumbers) Then
        TrySudoku = True
        Exit Function
    End If

    For Index = 1 To UBound(RemainNumbers)
        TryNumber = RemainNumbers(Index)
        
        UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, TryNumber
        If ScreenUpdate Then Cells(RowNumber, ColumnNumber) = TryNumber
                
        TryCounter = TryCounter + 1
        
        If TrySudoku(NumberMatrix) = True Then
            TrySudoku = True
            Exit Function
        End If
    Next
    
    UpdateNumberMatrix NumberMatrix, RowNumber, ColumnNumber, 0
    If ScreenUpdate Then
        Cells(RowNumber, ColumnNumber) = ""
        DoEvents
    End If
    TrySudoku = False
End Function

Function CheckNumberMatrix(ByRef NumberMatrix() As Long) As Long
    Dim ErrorInfos() As Variant
    Dim ErrorIndex As Long
    
    CheckNumberMatrix = InitNumberMatrix(NumberMatrix, ErrorInfos)
    
    If UBound(ErrorInfos) <= 0 Then
        Exit Function
    End If
    
    CheckNumberMatrix = -1
    For ErrorIndex = 1 To UBound(ErrorInfos)
        Cells(ErrorInfos(ErrorIndex)(0), ErrorInfos(ErrorIndex)(1)).Font.Color = vbRed
        Cells(ErrorInfos(ErrorIndex)(2), ErrorInfos(ErrorIndex)(3)).Font.Color = vbMagenta
    Next ErrorIndex
End Function

Function GetBlankPosition(ByRef NumberMatrix() As Long, ByRef TargetRowNumber As Long, ByRef TargetColumnNumber As Long, ByRef RemainNumbers() As Long) As Boolean
    Dim RemainNumbersMatrix(1 To 9, 1 To 9) As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim CheckRowNumber As Long
    Dim CheckColumnNumber As Long
    Dim CheckGroupItemNumber As Long
    Dim NumberValue As Long
    Dim Point As Long
    Dim MinPoint As Long
    Dim RemainNumberCounter As Long
    Dim NumberIndex As Long
    
    TargetRowNumber = 0
    TargetColumnNumber = 0
    ReDim RemainNumbers(0)
    
    GetBlankPosition = False
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            RemainNumberCounter = 0
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For NumberValue = 1 To 9
                    If _
                        RowDictArray(RowNumber, NumberValue) = 0 And _
                        ColumnDictArray(ColumnNumber, NumberValue) = 0 And _
                        GroupDictArray(GroupNumber, NumberValue) = 0 _
                    Then
                        RemainNumberCounter = RemainNumberCounter + 1
                    End If
                Next NumberValue
            End If
            RemainNumbersMatrix(RowNumber, ColumnNumber) = RemainNumberCounter
        Next RowNumber
    Next ColumnNumber
    
    MinPoint = 9999
    
    For RowNumber = 1 To 9
        For ColumnNumber = 1 To 9
            If NumberMatrix(RowNumber, ColumnNumber) = 0 Then
                Point = 1000 * RemainNumbersMatrix(RowNumber, ColumnNumber)
                
                PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
                
                For CheckColumnNumber = 1 To 9
                    If CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(RowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(RowNumber, CheckColumnNumber)
                    End If
                Next
                
                For CheckRowNumber = 1 To 9
                    If CheckRowNumber <> RowNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, ColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, ColumnNumber)
                    End If
                Next
                
                For CheckGroupItemNumber = 1 To 9
                    GroupToPosition GroupNumber, CheckGroupItemNumber, CheckRowNumber, CheckColumnNumber
                    If CheckRowNumber <> RowNumber And CheckColumnNumber <> ColumnNumber Then
                        If 0 < RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber) Then Point = Point + 1
                        'Point = Point + RemainNumbersMatrix(CheckRowNumber, CheckColumnNumber)
                    End If
                Next
                
                If Point < MinPoint Then
                    TargetRowNumber = RowNumber
                    TargetColumnNumber = ColumnNumber
                    MinPoint = Point
                End If
            End If
        Next ColumnNumber
    Next RowNumber

    If MinPoint < 9999 Then
        PositionToGroup TargetRowNumber, TargetColumnNumber, GroupNumber, GroupItemNumber
        For NumberValue = 1 To 9
            If _
                RowDictArray(TargetRowNumber, NumberValue) = 0 And _
                ColumnDictArray(TargetColumnNumber, NumberValue) = 0 And _
                GroupDictArray(GroupNumber, NumberValue) = 0 _
            Then
                ReDim Preserve RemainNumbers(UBound(RemainNumbers) + 1)
                RemainNumbers(UBound(RemainNumbers)) = NumberValue
            End If
        Next NumberValue
        
        GetBlankPosition = True
    End If
End Function

Sub UpdateNumberMatrix(ByRef NumberMatrix() As Long, ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByVal NumberValue As Long)
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim OldNumberValue As Long
    
    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
    
    OldNumberValue = NumberMatrix(RowNumber, ColumnNumber)
    
    If 0 < OldNumberValue Then
        RowDictArray(RowNumber, OldNumberValue) = 0
        ColumnDictArray(ColumnNumber, OldNumberValue) = 0
        GroupDictArray(GroupNumber, OldNumberValue) = 0
    End If
    
    If 0 < NumberValue Then
        RowDictArray(RowNumber, NumberValue) = ColumnNumber
        ColumnDictArray(ColumnNumber, NumberValue) = RowNumber
        GroupDictArray(GroupNumber, NumberValue) = GroupItemNumber
    End If

    NumberMatrix(RowNumber, ColumnNumber) = NumberValue
End Sub

Function InitNumberMatrix(ByRef NumberMatrix() As Long, ByRef ErrorInfos() As Variant) As Long
    Dim Index As Long
    Dim RowNumber As Long
    Dim ColumnNumber As Long
    Dim GroupNumber As Long
    Dim GroupItemNumber As Long
    Dim NumberValue As Long
    Dim ExistRowNumber As Long
    Dim ExistColumnNumber As Long
    
    InitNumberMatrix = 9 * 9
    
    ReDim ErrorInfos(0)
    
    For Index = 1 To 9
        For NumberValue = 1 To 9
            RowDictArray(Index, NumberValue) = 0
            ColumnDictArray(Index, NumberValue) = 0
            GroupDictArray(Index, NumberValue) = 0
        Next NumberValue
    Next Index
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            CalcPositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber
            PositionToGroupMap(RowNumber, ColumnNumber) = Array(GroupNumber, GroupItemNumber)
        Next RowNumber
    Next ColumnNumber
    
    For GroupNumber = 1 To 9
        For GroupItemNumber = 1 To 9
            CalcGroupToPosition GroupNumber, GroupItemNumber, RowNumber, ColumnNumber
            GroupToPositionMap(GroupNumber, GroupItemNumber) = Array(RowNumber, ColumnNumber)
        Next GroupItemNumber
    Next GroupNumber
    
    For ColumnNumber = 1 To 9
        For RowNumber = 1 To 9
            NumberValue = NumberMatrix(RowNumber, ColumnNumber)

            If NumberValue <> 0 Then
                If RowDictArray(RowNumber, NumberValue) Then
                    ExistRowNumber = RowNumber
                    ExistColumnNumber = RowDictArray(RowNumber, NumberValue)
                ElseIf ColumnDictArray(ColumnNumber, NumberValue) Then
                    ExistRowNumber = ColumnDictArray(ColumnNumber, NumberValue)
                    ExistColumnNumber = ColumnNumber
                Else
                    PositionToGroup RowNumber, ColumnNumber, GroupNumber, GroupItemNumber

                    If GroupDictArray(GroupNumber, NumberValue) Then
                        GroupToPosition GroupNumber, GroupDictArray(GroupNumber, NumberValue), ExistRowNumber, ExistColumnNumber
                    Else
                        ExistRowNumber = 0
                        ExistColumnNumber = 0

                        RowDictArray(RowNumber, NumberValue) = ColumnNumber
                        ColumnDictArray(ColumnNumber, NumberValue) = RowNumber
                        GroupDictArray(GroupNumber, NumberValue) = GroupItemNumber

                        InitNumberMatrix = InitNumberMatrix - 1
                    End If
                End If

                If 0 < ExistRowNumber Then
                    ReDim Preserve ErrorInfos(UBound(ErrorInfos) + 1)
                    ErrorInfos(UBound(ErrorInfos)) = Array(RowNumber, ColumnNumber, ExistRowNumber, ExistColumnNumber, NumberValue)
                End If
            End If
        Next RowNumber
    Next ColumnNumber
End Function

Sub PositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = PositionToGroupMap(RowNumber, ColumnNumber)(0)
    GroupItemNumber = PositionToGroupMap(RowNumber, ColumnNumber)(1)
End Sub

Sub GroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(0)
    ColumnNumber = GroupToPositionMap(GroupNumber, GroupItemNumber)(1)
End Sub

Sub CalcPositionToGroup(ByVal RowNumber As Long, ByVal ColumnNumber As Long, ByRef GroupNumber As Long, ByRef GroupItemNumber As Long)
    GroupNumber = Fix((RowNumber + 2) / 3) + 3 * (Fix((ColumnNumber + 2) / 3) - 1)
    GroupItemNumber = 1 + ((RowNumber + 2) Mod 3) + 3 * ((ColumnNumber + 2) Mod 3)
End Sub

Sub CalcGroupToPosition(ByVal GroupNumber As Long, ByVal GroupItemNumber As Long, ByRef RowNumber As Long, ByRef ColumnNumber As Long)
    RowNumber = 1 + 3 * ((GroupNumber - 1) Mod 3) + ((GroupItemNumber - 1) Mod 3)
    ColumnNumber = 1 + 3 * Fix((GroupNumber - 1) / 3) + Fix((GroupItemNumber - 1) / 3)
End Sub

きっかけ

はけた氏のツイート経由で、

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1｜VBAサンプル集

を見て、面白そうだったので、自分なりに書き下してみた。

エクセルのサンプルダウンロード｜エクセルの神髄

からダウンロードできる数独のエクセルファイル中のVBAを差し替えることで試用可能。

そのままだと面白くないので、

• 行／列／グループ（枠）それぞれの内に数字が存在するかどうかを連想配列で管理
• ↑の状態は初期化時に全セルをチェックし、その後は変化したセルに対してのみ書き換え

するようにしてみた。

とりあえず素直に、CreateObject("Scripting.Dictionary") を使ってみる……

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/444b3bf5dc68356fb14e296efde438bbfd6f465c

すると……元のコードと比べ、パフォーマンスが大幅に落ちてしまった(苦笑)。
※セルの更新を表示しないようにした状態で、4～5倍程度時間がかかってしまう。

CreateObject("Scripting.Dictionary") による連想配列がボトルネックっぽいなぁ……とアタリをつけて、その部分だけ単純な配列を疑似的な連想配列となるように使って置換。

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/1e6ac8b073952ab2eb0450f7fd77e643e435f3c4

元のコードと同等か少し落ちる程度のパフォーマンスは出るようにはなった（669回の試行で1.38秒→0.28秒とか）。

が……連想配列を使うことで元のコードにあるchkSu()相当処理の簡略化や、地味にループ回数を減らしたりしているのにパフォーマンスが上がらないということは、それを補って余りあるボトルネックがあるわけで……どこだ……少し時間を置いてから見直してみよう。　　

直感で、行列←→グループ（枠）の座標変換関数がボトルネックになっている気がしたので、計算を省いてショートカットするようにしてみた。

https://gist.github.com/furyutei/192911043d16f4793c7f21655482aca1/ceeee5dc9ddde4f27ad37771fdbef305c8894c3b

当たりだったっぽい。
総合的に、元のコードよりも約1割前後の速度向上が見られる模様。　　

なお、現時点ではコアとなるアルゴリズムは変更していないため、試行回数と結果は元のコードと同じになる（空きセル選択方法を微妙に調整していた名残もあるが……）。

数値があるかどうかをフラグ（ビット演算）で管理する版も置いておく。

• 変数宣言
• 初期化
• 判定1・判定2→判定1・判定2
• 状態更新

辺りで使用。

'\'演算子は、Mac版Excelに持って行ったときに問題がでる可能性を指摘されたので、Fix()を使用するように修正。

数値を設定する毎に、次に設定可能な値等の状態を履歴で保存するようにした版を作成。
参考：suudoku/suudoku11.bas at master · m-haketa/suudoku