転記先のひな形を維持したい

投稿者 : ちっぷ     投稿日時 : 2025/05/03(Sat) 10:28:21     OS : Windows 11     EXCEL : Excel 2021

---

お世話になります。
収納調書シートから会計①シートへ転記するように下記のコードを入れましたが、ひな形の罫線が消えてしまいます。
これをベースに、あと2つできたらいいなと思っています。

①会計シートの52行目に合計行を作成し、会計シートひな形の罫線を維持したい
②会計シートJ列に残高を入れたい

①については文字通りですが、Resize(3)の部分は必ず3行埋まるわけではないです
②については会計シートのJ列に単純に数式を入れていたのですが、マクロを実行すると入力された最終行より下の数式がすべて消えてしまいます。

ド素人がyoutubeを参考に少しいじっただけのコードです。
どなたかご指導お願いします。
※このコードを流用して、支出伺シートもあります

Sub 学級費_収()

　With Sheets("会計①").Cells(Rows.Count, "A").End(xlUp)
　　.Offset(1, 0).Resize(3) = Sheets("収納調書").Range("G2").Value '日付
　　.Offset(1, 1).Resize(3) = Sheets("収納調書").Range("I3").Value '整理番号
　　.Offset(1, 3).Resize(3) = Sheets("収納調書").Range("I5").Value '項目
　　.Offset(1, 4).Resize(3) = Sheets("収納調書").Range("C19:C21").Value '内訳
　　.Offset(1, 5).Resize(3) = Sheets("収納調書").Range("G19:G21").Value '単価
　　.Offset(1, 6).Resize(3) = Sheets("収納調書").Range("I19:I21").Value '数量
　　.Offset(1, 7).Resize(3) = Sheets("収納調書").Range("J19:J21").Value '金額
　End With

　'空白がある場合
　If WorksheetFunction.CountBlank(Sheets("会計①").Range("A1").CurrentRegion.Columns(5)) > 0 Then
　　'空白行を削除
　　Sheets("会計①").Range("A1").CurrentRegion.Columns(5).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　End If
　
　MsgBox "処理が完了しました。", 0, "確認"

End Sub

投稿者 : ピロリ     投稿日時 : 2025/05/03(Sat) 15:06:02

---

今一良く分かりませんが、E列（Columns(5)）の「内訳」が空白だった行を削除しているようですけど
行を削除してしまうのが 悪の根源 なのでは？
行を削除してしまっては、52行目の合計などもどんどん上の行へ上がってきてしまいますよ。
書き込んだ３行データに対してだけ、E列の「内訳」が空白の行をデータ消去（削除ではない）して、
上へ詰めるべきなのでは？　でないとフォーマットが維持できないと思います。

そういう観点でサンプルを揚げておきますが、的外れでしたら読み捨てて下さい。
合計や残高については良く分からないので、ご自分で関数を入力するなり処理して下さい。

Sub 学級費_収_改()
    Dim r As Long
    r = Sheets("会計①").Cells(Rows.Count, "A").End(xlUp).Row + 1   '書き込み先頭行
    If 49 < r Then                                                  '一応、エラー判定
        MsgBox "これ以上は書き込めません。", 0, "エラー"
        Exit Sub
    End If
    
    With Sheets("会計①").Cells(r, "A")
        .Offset(0, 0).Resize(3) = Sheets("収納調書").Range("G2").Value      '日付
        .Offset(0, 1).Resize(3) = Sheets("収納調書").Range("I3").Value      '整理番号
        .Offset(0, 3).Resize(3) = Sheets("収納調書").Range("I5").Value      '項目
        .Offset(0, 4).Resize(3) = Sheets("収納調書").Range("C19:C21").Value '内訳
        .Offset(0, 5).Resize(3) = Sheets("収納調書").Range("G19:G21").Value '単価
        .Offset(0, 6).Resize(3) = Sheets("収納調書").Range("I19:I21").Value '数量
        .Offset(0, 7).Resize(3) = Sheets("収納調書").Range("J19:J21").Value '金額
    End With
    
    Dim i As Long, j As Long, c As Long, buf(2, 7) As Variant
    c = 0
    For i = 0 To 2
        If Sheets("会計①").Cells(r + i, "E") <> "" Then            'E列が空白でないなら、
            For j = 0 To 7
                buf(c, j) = Sheets("会計①").Cells(r + i, "A").Offset(0, j) 'bufへ記録
            Next j
            c = c + 1
        End If
    Next i
    Sheets("会計①").Cells(r, "A").Resize(3, 8).Value = buf         '記録データの書き込み
    
    MsgBox "処理が完了しました。", 0, "確認"
    
End Sub

投稿者 : ちっぷ     投稿日時 : 2025/05/03(Sat) 16:19:38

---

教えていただいたコードを一つずつ読み解いてみます。
ありがとうございました。