|
??? |
|
Dim a(17) As Integer
Sub Macro1() Cells(1, 1).Value = 0 Call saiki(1) Cells(2, 1).Value = "=SUM(B1:B" & strr(Cells(1, 1).Value) & ")" End Sub Sub saiki(ByVal n As Integer) a(n) = 1 While a(n) <= 3 For j = 1 To 7 : For jj = 1 To 7 : b(j, jj) = 0 : Next jj : Next j x = 1 : y = 1 For j = 1 To n - 1 Select Case a(j) Case 1 : b(x, y) = 1 : b(x + 1, y) = 1 : b(x + 2, y) = 1 x = x + 3 Case 2 : b(x, y) = 1 : b(x, y + 1) = 1 : b(x, y + 2) = 1 x = x + 1 Case Else : b(x, y) = 1 x = x + 1 End Select QX = 0 While QX = 0 If x = 8 Then x = 1 : y = y + 1 If b(x, y) = 0 Then QX = 1 Else x = x + 1 End If Wend Next j QX = 1 Select Case a(n) Case 1 If x + 2 > 7 Then QX = 0 Else If b(x + 1, y) + b(x + 2, y) > 0 Then QX = 0 End If End If Case 2 If y + 2 > 7 Then QX = 0 Else If b(x, y + 1) + b(x, y + 2) > 0 Then QX = 0 End If End If Case Else wa = 0 For j = 1 To n If a(j) = 3 Then wa = wa + 1 Next j If wa > 1 Then QX = 0 End Select If QX Then If n < 17 Then Call saiki(n + 1) Else For j = 1 To 7 : For jj = 1 To 7 : b(j, jj) = 0 : Next jj : Next j x = 1 : y = 1 k = 0 : j = 1 While k = 0 And j <= 17 Select Case a(j) Case 1 : b(x, y) = 1 : b(x + 1, y) = 1 : b(x + 2, y) = 1 x = x + 3 Case 2 : b(x, y) = 1 : b(x, y + 1) = 1 : b(x, y + 2) = 1 x = x + 1 Case Else k = x + 7 * (y - 1) End Select If k = 0 Then QX = 0 While QX = 0 If x = 8 Then x = 1 : y = y + 1 If b(x, y) = 0 Then QX = 1 Else x = x + 1 End If Wend End If j = j + 1 Wend QX = 1 j = 1 While QX And j <= Cells(1, 1).Value If k = Cells(j, 2).Value Then QX = 0 Else j = j + 1 End If Wend If QX Then Cells(1, 1).Value = Cells(1, 1).Value + 1 Cells(Cells(1, 1).Value, 2).Value = k End If End If End If a(n) = a(n) + 1 Wend End Sub Private Function strr(ByVal n As Integer) As String strr = Right(Str(n), Len(Str(n)) - 1) End Function |
|
10月2日（金） 11:32:56
43748 |