VBA ソート等をした後の処理（見出しと罫線）

Question

###現在できていること

Sub Test()
    
  'データの並び替え
    Const topleft = "H11"
    With ActiveSheet
        .Range(topleft & ":R" & .Range(topleft).End(xlDown).Row).Sort key1:=Range(topleft)
    End With
    ' H列の値ごとに空白行を挿入、合計という値とsum関数を入れる
    Dim st As Worksheet: Set st = ActiveSheet
    Dim c As Long: c = 8
    Dim r As Long: r = 11
    
    Dim tmp As String
    tmp = "合 計"
    
    Dim cnt As Long
    cnt = r
    
    Do While r <= st.UsedRange.Rows.Count
    Dim a As Variant: a = st.Cells(r - 1, c).Value
    Dim b As Variant: b = st.Cells(r, c).Value
    
    If a <> "" And b <> "" And Left(a, 3) <> Left(b, 3) And r <> 11 Then
        st.Rows(r).Insert
        st.Cells(r, 14).Value = tmp
        st.Cells(r, 15).Value = "=sum(R[" & cnt - r & "]C:R[-1]C)"
        st.Cells(r, 15).NumberFormatLocal = "[h]:mm"
        cnt = r + 1
    End If
    
    r = r + 1
    
    Loop
    
    st.Cells(r, 14).Value = tmp
    st.Cells(r, 15).Value = "=sum(R[" & cnt - r & "]C:R[-1]C)"
    
    Set st = Nothing

End Sub

現在、こちらのサイトのお陰もあり上記のようなコードによって、思っている動作をしております。
さらに、追加したい部分として、、、
0. H列（氏名）毎に空白行は空くが、そこに見出しを追加したい。
0. 1人分毎に罫線を引いて、表のようにしたい。
この2点になります。

###現在の表と、理想の形
現在上記のコードを行った後の状態です。

※実際は値がO列までは確実に入っているのですが、とりあえずなので入れていません。
※行番号等はわかりやすくなるかと思って、打ち込んでいます。実際は空白です。
※データを打ち込むのにわかりやすいように、最初には見出しをすでに置いてあります。

次に、理想の形です。

最初の見出しと同じものを入れていく。
線に関しては、これだと逆にみづらい気もしますが、とりあえずこのような感じになれば良いと思っています。

###やったこと
ほとんどＶＢＡを勉強しはじめなので、わからないままやっております。
空白行を３行にするのはできたけど、見出しの部分のコピーの仕方？
コピーすればっていうのはあっても、それをコピー先の指定などがイマイチです。

すみません、やったことではないのですが、、、

現状のコードの中に組み込むよりは別にしたほうがいいならばそれでも全然構いません。
どうか、よろしくお願い致します。

Answer 1

追加したのは3行だけです。
罫線をひく
[http://officetanaka.net/excel/vba/cell/cell07.htm]
前回に続き力ずくに対応していますので、項目の変更やセルの変更等があると手間がかかると思われます。

Sub Test()

  'データの並び替え
    Const topleft = "H11"
    With ActiveSheet
        .Range(topleft & ":R" & .Range(topleft).End(xlDown).Row).Sort key1:=Range(topleft)
    End With
    ' H列の値ごとに空白行を挿入、合計という値とsum関数を入れる
    Dim st As Worksheet: Set st = ActiveSheet
    Dim c As Long: c = 8
    Dim r As Long: r = 11

    Dim tmp As String
    tmp = "合 計"

    Dim cnt As Long
    cnt = r

    Do While r <= st.UsedRange.Rows.Count
    Dim a As Variant: a = st.Cells(r - 1, c).Value
    Dim b As Variant: b = st.Cells(r, c).Value

    If a <> "" And b <> "" And Left(a, 3) <> Left(b, 3) And r <> 11 Then
        st.Rows(r).Insert
        st.Cells(r, 14).Value = tmp
        st.Cells(r, 15).Value = "=sum(R[" & cnt - r & "]C:R[-1]C)"
        st.Cells(r, 15).NumberFormatLocal = "[h]:mm"
        
        '見出しのコピー
        st.Rows(r + 1 & ":" & r + 2).Insert xlShiftDown
        st.Range("H9:R10").Copy Destination:=st.Range("H" & r + 1 & ":R" & r + 2)
        
        cnt = r + 1
    End If

    r = r + 1

    Loop

    st.Cells(r, 14).Value = tmp
    st.Cells(r, 15).Value = "=sum(R[" & cnt - r & "]C:R[-1]C)"
    st.Cells(r, 15).NumberFormatLocal = "[h]:mm"
    
    '全体に罫線を引く
    Range("H9:R" & r).Borders.LineStyle = xlContinuous
    
    Set st = Nothing

End Sub

Comments

[Z-TALBO]

素早い回答と、前回の質問に続き大変参考になりました！！！