清华大佬耗费三个月吐血整理的几百G的资源，免费分享！....>>>
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | Rem Attribute VBA_ModuleType=VBAModuleOption VBASupport 1Option 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 IfEnd FunctionSub go() Dim rel As Integer ' rel = setNextValFromRowCol(2, 2) MsgBox "結果：" & relEnd SubFunction 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 rowEnd FunctionFunction 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 = valEnd 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 |