投稿/コメントを表示します。

問題文だけ参照にし、
ノーヒントで罫線を引く部分まで作りました(通し番号が振られていない前提で作成)。
きちんと動きました…(大丈夫でしょうか?)。
一度、紙で印刷してみたら、A4用紙3枚分位になりました。

勉強を始めて2か月程でこんなに書けるようになるなんて思っていませんでした。感謝しています。
引き続き、よろしくお願いします(そろそろ、フォローメールセミナー30題にも取り掛かっていきたいと思っています)。
Option Explicit

Dim wFm, wTo, wS, wA As Worksheet
Dim cMx, cCo, cTo As Long
Dim daHiduke As Date
Dim strNamae As String

Sub Zentai()
    Set wFm = Worksheets("main")
    Set wTo = Worksheets("main1")
    cMx = wFm.Range("B" & wFm.Rows.Count).End(xlUp).Row
    cCo = 2
        Delete_Sheet
        Tooshi_bangou
    cCo = 2
        NarabekaeB
    cTo = 16
        Sheet_Create_Kakikomi
    cCo = 2
    strNamae = ""
        NarabekaeA
        Sakujo_Tooshibangou
End Sub

Sub Delete_Sheet()
       For Each wS In Worksheets
       Application.DisplayAlerts = False
           If wS.Name <> "main1" And wS.Name <> "main" Then
                wS.Delete
           End If
       Next
       Application.DisplayAlerts = True
End Sub

Sub Tooshi_bangou()
    For cCo = 2 To cMx
        wFm.Range("A" & cCo).Value = cCo - 1
    Next
End Sub

Sub NarabekaeB()
    With wFm
        wFm.Sort.SortFields.Clear
        wFm.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:G" & cMx)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

Sub Sheet_Create_Kakikomi()
    For cCo = 2 To cMx
        If wFm.Range("B" & cCo).Value <> strNamae Then
            If strNamae <> "" Then
                wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
                Keisen
            End If
            cTo = 16
            strNamae = wFm.Range("B" & cCo).Value
            wTo.Copy after:=wFm
            Set wA = ActiveSheet
            wA.Name = strNamae
            wA.Range("J12").Value = strNamae
        End If
        With wA.Range("B" & cTo)
            .Offset().Value = Year(wFm.Range("C" & cCo).Value)       'wA B
            .Offset(, 1).Value = Month(wFm.Range("C" & cCo).Value)       'wA C
            .Offset(, 2).Value = Day(wFm.Range("C" & cCo).Value)         'wA D
            .Offset(, 3).Value = wFm.Range("D" & cCo).Value                  'wA E
            .Offset(, 4).Value = wFm.Range("E" & cCo).Value                  'wA F
            .Offset(, 6).Value = wFm.Range("F" & cCo).Value                  'wA G
            Select Case wFm.Range("G" & cCo).Value                                                     'H
                Case Is > 0
                    .Offset(, 7).Value = wFm.Range("G" & cCo).Value              'wA I
                Case Is < 0
                    .Offset(, 8).Value = wFm.Range("G" & cCo).Value              'wA J
            End Select
            If cTo = 16 Then
                .Offset(, 9).Value = .Offset(, 7).Value + .Offset(, 8).Value       'wA K= wA I+ wA J
            Else
                .Offset(, 9).Value = wA.Range("K" & cTo - 1).Value + .Offset(, 7).Value + .Offset(, 8).Value      'wA K=wA Kの一個上+wA I+ wA J
            End If
        End With
        cTo = cTo + 1
    Next
    wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
    Keisen
End Sub

Sub NarabekaeA()
    With wFm
        wFm.Sort.SortFields.Clear
        wFm.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:G" & cMx)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

Sub Sakujo_Tooshibangou()
    wFm.Range("A2:A" & cMx).ClearContents
End Sub

Sub Keisen()
    With wA.Range("B16:K" & cTo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub

2017/10/14 01:43