Sub 数値の代入()
' 2022.10.12 v3.0

Dim i, j, k, l As Integer

Range("A1:T15").Font.ColorIndex = 0
Range("A1:T15").Interior.ThemeColor = 1

'セル入力の先頭０を削除
For i = 1 To 15
    If 0 = Mid(Cells(i, 25).Value, 1, 1) Then
        Cells(i, 25).Characters(1, 1).Delete
    End If
Next i

k = 0
For j = 1 To 20 Step 3
l = 0
    k = k + 1
    For i = 1 To 7
    
        '一列目の入力値を配列に代入
        Cells(i, j).Value = Mid(Cells(k, 25).Value, i, 1)
        Cells(i, j + 1).Value = Cells(i, j).Value
        
        l = l + 1
        '二列目の入力値を配列に代入
        Cells(i + 8, j).Value = Mid(Cells(k + 8, 25).Value, l, 1)
        Cells(i + 8, j + 1).Value = Cells(i + 8, j).Value
        
        '一列目の先頭
        If i = 1 And Cells(1, j).Value <> "" Then
            Cells(Cells(1, j).Value + 1, 22).Copy Destination:=Cells(1, j)
            Cells(1, j).Copy Destination:=Cells(1, j + 1)
        End If
        '二列目の先頭
        If i = 1 And Cells(9, j).Value <> "" Then
            Cells(Cells(9, j).Value + 1, 22).Copy Destination:=Cells(9, j)
            Cells(9, j).Copy Destination:=Cells(9, j + 1)
        End If
        
        '一列目の最後尾
        If i = 7 And Cells(7, j).Value <> "" Then
            Cells(Cells(7, j).Value + 1, 22).Copy Destination:=Cells(7, j)
            Cells(7, j).Copy Destination:=Cells(7, j + 1)
        End If
        '二列目の最後尾
        If i = 7 And Cells(15, j).Value <> "" Then
            Cells(Cells(15, j).Value + 1, 22).Copy Destination:=Cells(15, j)
            Cells(15, j).Copy Destination:=Cells(15, j + 1)
        End If
        
        '一列目の６桁入力
        If i = 7 And Cells(1, j).Value <> "" And Cells(7, j).Value = "" Then
            Cells(Cells(6, j).Value + 1, 22).Copy Destination:=Cells(6, j)
            Cells(6, j).Copy Destination:=Cells(6, j + 1)
        End If
        '二列目の６桁入力
        If i = 7 And Cells(9, j).Value <> "" And Cells(15, j).Value = "" Then
            Cells(Cells(14, j).Value + 1, 22).Copy Destination:=Cells(14, j)
            Cells(14, j).Copy Destination:=Cells(14, j + 1)
        End If
    Next i
Next j

End Sub
Sub データ消去()
    
    Range("A1:T15").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.ClearContents
    Range("Y1").Select
End Sub