上級171回のコード
Sub test7()
Dim 行数 As Integer
Dim 列数 As Integer
Dim c As Integer
Dim r As Integer
Dim i As Integer
Dim n As Integer
Dim sum As Integer
Dim d As Integer
Dim nums As Collection
Dim nd As NumData
Const 数 As Integer = 0
Const 完了 As Integer = 1
Dim 塗れる配列() As Integer
Dim 現状() As Integer
Dim mark As Integer
Dim cnt As Integer
Dim 空白 As Integer
'削除
' Dim fof As Integer
' Dim lof As Integer
' Dim of As Integer
'追加
Dim of(1) As Integer
Const F As Integer = 0
Const L As Integer = 1
Dim x(1) As Integer
Dim y As Integer
Dim k As Integer
Dim fg1 As Boolean
Dim 基点 As Range
Set 基点 = ThisWorkbook.Worksheets(2).Range("D4")
行数 = 8
列数 = 8
ReDim 現状(1 To 行数)
For c = 1 To 列数
If 基点.Offset(0, c) <> "" Then
'数字の取り込み
Set nums = New Collection
i = 0
sum = 0
Do While 基点.Offset(i, c) <> ""
Set nd = New NumData
nd.num = 基点.Offset(i, c)
nums.Add nd
sum = sum + 基点.Offset(i, c)
i = i - 1
Loop
'現在の状態を取得
For r = 1 To 行数
Select Case 基点.Offset(r, c).Interior.Color
Case RGB(0, 0, 0)
現状(r) = 1
Case RGB(255, 240, 230)
現状(r) = 2
Case Else
現状(r) = 0
End Select
Next r
'隙間を埋める処理
fof = 0
lof = 0
of = 0
r = 1
空白 = 0
Do While r <= 行数
If 現状(r) = 1 Then
Exit Do
ElseIf 現状(r) = 0 Then
空白 = 空白 + 1
ElseIf 現状(r) = 2 Then
'of = of + 1
If 空白 < nums(nums.Count).num Then
'*********************************
'test5から下記位置に修正
of = of + 1
For i = 1 To 空白
基点.Offset(r - i, c).Interior.Color = RGB(255, 240, 230)
of = of + 1
Next i
fof = of
空白 = 0
Else
Exit Do
End If
End If
r = r + 1
Loop
of = 0
r = 行数
空白 = 0
Do While r >= 1
If 現状(r) = 1 Then
Exit Do
ElseIf 現状(r) = 0 Then
空白 = 空白 + 1
ElseIf 現状(r) = 2 Then
' of = of + 1
If 空白 < nums(1).num Then
'*********************************
'test5から下記位置に修正
of = of + 1
For i = 1 To 空白
基点.Offset(r + i, c).Interior.Color = RGB(255, 240, 230)
of = of + 1
Next i
lof = of
空白 = 0
Else
Exit Do
End If
End If
r = r - 1
Loop
'両端から塗られている所を探す
For k = 0 To 1
If x(k) = 1 Then
y = nums(nums.Count).num
Else
y = nums(1).num
End If
cnt = 0
mark = 0
For r = 1 + of(k) To y + of(k)
If x(k) = 1 Then
target = r
Else
target = 行数 - r + 1
End If
If 現状(target) = 1 And mark = 0 Then
mark = r
cnt = cnt + 1
ElseIf mark > 0 Then
基点.Offset(target, c).Interior.Color = RGB(0, 0, 0)
cnt = cnt + 1
End If
Next r
If cnt = y Then
If r < 行数 + 1 Then
基点.Offset(target + x(k), c).Interior.Color = RGB(255, 240, 230)
End If
End If
Next k
'最後から塗られている所を探す
' For r = 1 + of(L) To nums(1).num + of(L)
' If 現状(行数 - r + 1) = 1 And mark = 0 Then
' mark = r
' cnt = cnt + 1
' ElseIf mark > 0 Then
' 基点.Offset(行数 - r + 1, c).Interior.Color = RGB(0, 0, 0)
' cnt = cnt + 1
'
' End If
'
' Next r
'
' If cnt = nums(1).num Then
' If r < 行数 + 1 Then
' 基点.Offset(行数 - r + 1, c).Interior.Color = RGB(255, 240, 230)
' End If
' End If
'ジャストフィット
If (nums.Count - 1 + sum) = 行数 - of(F) - of(L) Then
i = 1
For d = 1 To nums.Count
n = 1
Do While n <= nums(d).num
基点.Offset(行数 - i + 1 - of(L), c).Interior.Color = RGB(0, 0, 0)
i = i + 1
n = n + 1
Loop
If nums.Count > d Then
基点.Offset(行数 - i + 1 - of(L), c).Interior.Color = RGB(255, 240, 230)
i = i + 1
End If
Next d
'合計が半分を超える場合
ElseIf (nums.Count - 1 + sum) > ((行数 - of(F) - of(L)) / 2) Then
塗れる配列 = 絶対塗れるヤツ(行数 - of(F) - of(L), nums)
For i = 1 To 行数 - of(F) - of(L)
If 塗れる配列(i) = 1 Then
基点.Offset(行数 - of(L) - i + 1, c).Interior.Color = RGB(0, 0, 0)
End If
Next i
End If
Else
基点.Offset(1, c).Resize(行数, 1).Interior.Color = RGB(255, 240, 230)
End If
Next c
End Sub