清华大佬耗费三个月吐血整理的几百G的资源，免费分享！....>>>
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Option Explicit
' 機能：取得数字
' 引数：基礎値、行数、列数
Public Function getValOfRowCol(baseVal As Integer, rowNo As Integer, colNo As Integer) As Integer
Dim val As Integer
getValOfRowCol = 0
If Cells(rowNo, colNo) = "" Then
'空白
For val = baseVal To 9
If checkRow(val, rowNo) = 0 Then
If checkCol(val, colNo) = 0 Then
If checkBlock(val, rowNo, colNo) = 0 Then
getValOfRowCol = val
Exit For
End If
End If
End If
Next val
End If
End Function
Sub go()
Dim rel As Integer
'
rel = setNextValFromRowCol(2, 2)
MsgBox "結果：" & rel
End Sub
Function setNextValFromRowCol(fromRow As Integer, fromCol As Integer) As Integer
'OK:0 NG:1
Dim val As Integer
Dim NextRow As Integer
Dim NextCol As Integer
Dim baseVal As Integer
If fromRow = 11 Then
MsgBox "OK、完了！"
End
End If
If Cells(fromRow, fromCol).Font.Size = 26 Then
'固有数字
'次のセルを探す
'If fromCol = 10 Then
' NextRow = fromRow + 1
' NextCol = 2
'Else
' NextRow = fromRow
' NextCol = fromCol + 1
'End If
Call getBestRowCol(NextRow, NextCol)
If NextRow = 0 Then
MsgBox "完了！"
End
End If
If setNextValFromRowCol(NextRow, NextCol) = 0 Then
setNextValFromRowCol = 0
Else
setNextValFromRowCol = 1
End If
Else
'現在値をセットする
For baseVal = 1 To 9
val = getValOfRowCol(baseVal, fromRow, fromCol)
If val <> 0 Then
Cells(fromRow, fromCol) = val
'次のセルを探す
'If fromCol = 10 Then
' NextRow = fromRow + 1
' NextCol = 2
'Else
' NextRow = fromRow
' NextCol = fromCol + 1
'End If
Call getBestRowCol(NextRow, NextCol)
If NextRow = 0 Then
MsgBox "完了！"
End
End If
If setNextValFromRowCol(NextRow, NextCol) = 1 Then
Cells(fromRow, fromCol) = ""
setNextValFromRowCol = 1
End If
baseVal = val
Else
setNextValFromRowCol = 1
Exit For
End If
Next baseVal
End If
End Function
'行合理性チェック(0:OK, 1:NG)
Function checkRow(val, rowNo)
Dim col As Integer
Dim flg As Integer
flg = 0
For col = 2 To 10
If val = Cells(rowNo, col) Then
flg = 1
End If
If flg = 1 Then Exit For
Next col
checkRow = flg
End Function
'列合理性チェック(0:OK, 1:NG)
Function checkCol(val, colNo)
Dim row As Integer
Dim flg As Integer
flg = 0
For row = 2 To 10
If val = Cells(row, colNo) Then
flg = 1
End If
If flg = 1 Then Exit For
Next row
checkCol = flg
End Function
'BLOCK合理性チェック(0:OK, 1:NG)
Function checkBlock(val, rowNo, colNo)
Dim row As Integer
Dim col As Integer
Dim brow As Integer
Dim bcol As Integer
Dim flg As Integer
flg = 0
brow = Fix((rowNo - 2) / 3)
bcol = Fix((colNo - 2) / 3)
If brow < 0 Then brow = 0
If bcol < 0 Then bcol = 0
For row = 1 To 3
For col = 1 To 3
If val = Cells(brow * 3 + row + 1, bcol * 3 + col + 1) Then
flg = 1
End If
If flg = 1 Then Exit For
Next col
If flg = 1 Then Exit For
Next row
checkBlock = flg
End Function
'最優先するセルを選択
Function getBestRowCol(ByRef retRow As Integer, ByRef retCol As Integer)
Dim row As Integer
Dim col As Integer
Dim valSpace As Integer '空白評価値
Dim minValSpace As Integer
retRow = 0
retCol = 0
minValSpace = 9999
For row = 2 To 10
For col = 2 To 10
If Cells(row, col) = "" Then
valSpace = cntspace(row, col)
If valSpace < minValSpace And valSpace > 0 Then
retRow = row
retCol = col
minValSpace = valSpace
End If
End If
Next col
Next row
End Function
Function cntspace(row As Integer, col As Integer) As Integer
'セル所在場所の空白数計算
Dim rowSpace As Integer
Dim colSpace As Integer
Dim blkSpace As Integer
Dim val As Integer
'所在行数の空白数
rowSpace = cntRowSpace(row)
colSpace = cntColSpace(col)
blkSpace = cntBlkSpace(row, col)
val = rowSpace
If colSpace < val Then val = colSpace
If blkSpace < val Then val = blkSpace
cntspace = val
End Function
'行空数を計算
Function cntRowSpace(row As Integer) As Integer
Dim col As Integer
Dim cnt As Integer
cnt = 0
For col = 2 To 10
If Cells(row, col) = "" Then
cnt = cnt + 1
End If
Next col
cntRowSpace = cnt
End Function
'列空数を計算
Function cntColSpace(col As Integer) As Integer
Dim row As Integer
Dim cnt As Integer
cnt = 0
For row = 2 To 10
If Cells(row, col) = "" Then
cnt = cnt + 1
End If
Next row
cntColSpace = cnt
End Function
'Block空数を計算
Function cntBlkSpace(row As Integer, col As Integer) As Integer
Dim cnt As Integer
Dim rblock As Integer
Dim cblock As Integer
Dim i As Integer
Dim j As Integer
cnt = 0
rblock = Fix((row - 2) / 3)
cblock = Fix((col - 2) / 3)
For i = 1 To 3
For j = 1 To 3
If Cells(rblock * 3 + i + 1, cblock * 3 + j + 1) = "" Then
cnt = cnt + 1
End If
Next j
Next i
cntBlkSpace = cnt
End Function