上級169回のコード

Sub test5()

    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 基点 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
                        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
                        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
            
            '先頭から塗られている所を探す
            cnt = 0
            mark = 0
            
            For r = 1 + fof To nums(nums.Count).num + fof
                If 現状(r) = 1 And mark = 0 Then
                    mark = r
                    cnt = cnt + 1
                ElseIf mark > 0 Then
                    基点.Offset(r, c).Interior.Color = RGB(0, 0, 0)
                    cnt = cnt + 1
                End If
            
            Next r
            
            If cnt = nums(nums.Count).num Then
                If r < 行数 + 1 Then
                    基点.Offset(r, c).Interior.Color = RGB(255, 240, 230)
                End If
            End If

            cnt = 0
            mark = 0
            
            '最後から塗られている所を探す


            For r = 1 + lof To nums(1).num + lof
                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) = 行数 Then
                i = 1
                For d = 1 To nums.Count
                    n = 1
                    
                    Do While n <= nums(d).num
                        基点.Offset(行数 - i + 1, c).Interior.Color = RGB(0, 0, 0)
                        i = i + 1
                        n = n + 1
                    Loop
                    
                    If nums.Count > d Then
                        基点.Offset(行数 - i + 1, c).Interior.Color = RGB(255, 240, 230)
                        i = i + 1
                    End If
                Next d
                    
            
            '合計が半分を超える場合
            ElseIf (nums.Count - 1 + sum) > (行数 / 2) Then
            
                塗れる配列 = 絶対塗れるヤツ(行数, nums)

                For i = 1 To 行数
                    If 塗れる配列(i) = 1 Then
                        基点.Offset(行数 - 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

Option Explicit

Public num As Integer
Public fg As Boolean