お疲れ様です。
追加課題2件やってみましたので、ご確認お願いします。

　●追加課題1件目
　[1] 伝票用テンプレートには、以下の欠点がありますので、マクロの中でそれを修正してください。
　　1. ヘッダー、フッターが挿入されていない
　　2. 印刷範囲の設定が狭くこのままでは、どの取引先の伝票も
　　印刷時に実データが印刷されません。

　●追加課題2件目
　[2] すべての処理が終わった後、A列で並べ替え、
　そして、A列のデータ全てを削除します。
（つまり、シートmainの状態は、マクロ実行前とまったく同じに戻します）

　所感
　　印刷設定に関してはネットで調べたり、手探りでやってみましたので、
自信はあまりないです が、会社毎の伝票作成に入る前の段階で( denpyo_createより前)
main1シートのテンプレの印刷設定( ヘッダー、フッタ ー、 印刷範囲)をするプログラム
( shmain1_print_setting)で組んでみました。

Option Explicit

Dim gst_retu As String

Public Sub main()
    '「main」と[main1]シート以外のワークシートを削除する
    sh_delete
    
    '追加課題1:プリンターのヘッダーとフッター、印刷範囲の設定をする
    shmain1_print_setting
    
    '「No.」の列に番号を割り振る
    shmain_no_assign
    
    '取引先名称で並べ替える
    gst_retu = "B"
    shmain_asc_sort
    
    '取引先名称ごとに伝票を作成する
    denpyo_create

    '「No.」の列を並べ替える
    gst_retu = "A"
    shmain_asc_sort
    
    '追加課題[2]:A列のデータ全てを削除する
    shmain_no_delete
End Sub

Private Sub shmain_asc_sort()
    Dim wfm_sh As Worksheet
    Dim cfm_mx As Long
    Set wfm_sh = Worksheets("main")
    
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    wfm_sh.Range("A1:G" & cfm_mx).Sort _
        Key1:=wfm_sh.Range(gst_retu & 1), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub

Private Sub shmain_no_assign()
    Dim wfm_sh As Worksheet
    Dim cfm_gyo  As Long
    Dim cfm_mx As Long
    Set wfm_sh = Worksheets("main")
    
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    wfm_sh.Range("A2").FormulaR1C1 = "1"
    wfm_sh.Range("A3").FormulaR1C1 = "2"
    wfm_sh.Range("A2:A3").AutoFill Destination:=wfm_sh.Range("A2:A" & cfm_mx)

End Sub

Private Sub denpyo_create()
    Dim wfm_sh As Worksheet
    Dim wto_sh As Worksheet
    Dim stfm_torihikisaki As String
    Dim cfm_gyo As Long
    Dim cfm_mx As Long
    Dim cto_cnt As Long
    Dim cfm_kingaku  As Long
    Dim dtfm As Date
    
    Set wfm_sh = Worksheets("main")
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    For cfm_gyo = 2 To cfm_mx
        If stfm_torihikisaki <> wfm_sh.Range("B" & cfm_gyo).Value Then
            If cfm_gyo > 2 Then
                denpyo_rasenn_draw
            End If
            cto_cnt = 16
            stfm_torihikisaki = wfm_sh.Range("B" & cfm_gyo).Value
            Sheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Set wto_sh = ActiveSheet
            wto_sh.Name = stfm_torihikisaki
        End If
    
        wto_sh.Range("E" & cto_cnt).Value = wfm_sh.Range("D" & cfm_gyo).Value
        
        wto_sh.Range("F" & cto_cnt).Value = wfm_sh.Range("E" & cfm_gyo).Value

        wto_sh.Range("H" & cto_cnt).Value = wfm_sh.Range("F" & cfm_gyo).Value
        
        dtfm = wfm_sh.Range("C" & cfm_gyo).Value
        
        wto_sh.Range("B" & cto_cnt).Value = Format(dtfm, "yy")
        wto_sh.Range("C" & cto_cnt).Value = Format(dtfm, "mm")
        wto_sh.Range("D" & cto_cnt).Value = Format(dtfm, "dd")
            
        cfm_kingaku = wfm_sh.Range("G" & cfm_gyo).Value
    
        If cfm_kingaku > 0 Then
            wto_sh.Range("I" & cto_cnt).Value = cfm_kingaku
        Else
            wto_sh.Range("J" & cto_cnt).Value = cfm_kingaku
        End If
    
        wto_sh.Range("K" & cto_cnt).Value = wto_sh.Range("K" & cto_cnt - 1).Value + cfm_kingaku
        cto_cnt = cto_cnt + 1
    Next
    denpyo_rasenn_draw
    wfm_sh.Activate
End Sub

Private Sub denpyo_rasenn_draw()
    Dim cto_mx As Long
    cto_mx = Range("K1048576").End(xlUp).Row + 1
    
    With Range("B16:K" & cto_mx).Borders
        .Item(xlEdgeLeft).LineStyle = xlContinuous
        .Item(xlEdgeTop).LineStyle = xlContinuous
        .Item(xlEdgeBottom).LineStyle = xlContinuous
        .Item(xlEdgeRight).LineStyle = xlContinuous
        .Item(xlInsideVertical).LineStyle = xlContinuous
        .Item(xlInsideHorizontal).LineStyle = xlContinuous
    End With

End Sub

Private Sub shmain1_print_setting()
    Dim wmain1_sh As Worksheet
    Set wmain1_sh = Worksheets("main1")
    
    With wmain1_sh.PageSetup
        
        '追加課題[1]-1
        '[1]-1 伝票用テンプレートには､以下の欠点がありますので､マクロの中でそれを修正してくださ 
               い｡
         '1. ヘッダー、フッターが挿入されていない
        
        ' 中央ヘッダーに、シート名が中央に配置され、そのフォントサイズが16に設定する
        .CenterHeader = "&A&16"
        
        ' 右ヘッダー現在の日付を設定する
        .RightHeader = "&D"
        
        ' 中央フッターに「ページ番号と総ページ数」を設定する
        .CenterFooter = "&P / &N"
        
        '追加課題[1]-2
        '2. 印刷範囲の設定が狭くこのままでは、どの取引先の伝票も印刷時に実データが印刷されません｡

        ' ページの方向を縦に設定
        .Orientation = xlPortrait
    
        ' 用紙のサイズをA4に設定
        .PaperSize = xlPaperA4

        ' 印刷範囲を設定（B列からK列までの列）
        .PrintArea = "B:K"
        
        '横方向に1ページに収める
        .FitToPagesWide = 1
        
        '縦方向に1ページに収める
        .FitToPagesTall = 1
    End With

End Sub


Private Sub shmain_no_delete()
    '追加課題[2]
    '[2] すべての処理が終わった後､A列で並べ替え､(shmain_asc_sortで並び替え済み。)
    'そして､A列のデータ全てを削除します｡
    '（つまり、シートmainの状態は、マクロ実行前とまったく同じに戻します）
        
    Dim wfm_sh As Worksheet
    Dim cfm_gyo  As Long
    Dim cfm_mx As Long
    Set wfm_sh = Worksheets("main")
    
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    wfm_sh.Range("A2:A" & cfm_mx).ClearContents
End Sub

Public Sub sh_delete()
    Dim wks As Worksheet
    Application.DisplayAlerts = False
    
    For Each wks In Worksheets
        If Left(wks.Name, 4) <> "main" Then
            wks.Delete
        End If
        
    Next
    Application.DisplayAlerts = True
End Sub

2023/12/30 04:19