ＦＡＸ注文書作成の時短効果と無料に仰天！知った人だけラッキーです。

Sub メインデータ転記()
Dim Nrow As Long
Dim e As Long, ee As Long, x As Long
Dim Sn As String
Worksheets("発注資料表").Select
Nrow = Cells(Rows.Count, 13).End(xlUp).Row
       e = Nrow Mod 9
       ee = Nrow \ 9
    If ee = 0 Then
        If e < 3 Then
           MsgBox "作成するＦＡＸ注文書はありません。", vbOKOnly + vbInformation, "注文書作成"
           Worksheets("設定とスタート").Select
           Exit Sub
        Else
           x = 1
        End If
    Else
        x = ee + 1
    End If
    For s = x To 1 Step -1
            Sn = "Ｐ" & s
            Worksheets("テンプレート").Select
            Worksheets("テンプレート").Copy after:=Worksheets("テンプレート")
            ActiveSheet.Name = Sn
    Next s

Dim PR As Long
Dim BV As Variant, SUV As String, SOV As String, TYV As String
Dim SAV As Variant, HOV As Variant, SIV As Variant, HAV As Variant
Dim SJV As String, ISV As String, KYV As Variant, TDV As String

    For s = 1 To x
            Sn = "Ｐ" & s
                For t = 1 To 5
                    Worksheets("発注資料表").Select
                    PR = WorksheetFunction.Match(Sn, Worksheets("発注資料表").Columns("A"), 0) + 1
                    BV = Range("A" & PR + t)        '分類名
                    SUV = Range("B" & PR + t)       '出版社名
                    SOV = Range("C" & PR + t)       '書名
                    TYV = Range("D" & PR + t)       '著者名
                    SAV = Range("E" & PR + t)       '冊数
                    HOV = Range("F" & PR + t)       '本体価格
                    SIV = Range("G" & PR + t)       'シリーズ名
                    HAV = Range("H" & PR + t)       '版数
                    SJV = Range("I" & PR + t)       '送品条件
                    ISV = Range("J" & PR + t)       'ＩＳＢＮ
                    KYV = Range("K" & PR + t)       '客注名
                If SOV = "" Then
                    TDV = ""
                Else
                    TDV = Date
                End If                              '発注日
                    Worksheets(Sn).Select
                    tt = (t - 1) * 4
                    Cells(3, 22 - tt) = SAV
                    Cells(4, 21 - tt) = "ＩＳＢＮ " & ISV
                    Cells(5, 21 - tt) = SJV
                    Cells(7, 24 - tt) = SUV
                    Cells(7, 22 - tt) = SIV & vbCrLf & SOV
                    Cells(9, 24 - tt) = TYV
                    Cells(10, 22 - tt) = HAV & "版"
                    Cells(11, 22 - tt) = HOV
                    Cells(12, 22 - tt) = TDV
                    Cells(13, 22 - tt) = KYV
                    Cells(15, 21 - tt) = BV
                If SUV <> "" Then
                    Range("AD2") = SUV & "　　様"
                End If
                Next t
    Next s

Sub 発信元セット()
   Dim HJa As Variant, HJb As Variant, HJc As Variant, HJd As Variant, HJe As Variant
   Worksheets("設定とスタート").Select
	HJa = Range("I3")
	HJb = Range("I4")
	HJc = Range("I5")
	HJd = Range("I6")
	HJe = Range("I7")

   Worksheets("テンプレート").Select
	Range("AD10") = HJa
	Range("AC10") = HJb
	Range("AB10") = HJc
	Range("AA10") = HJd
	Range("Z10") = HJe
End Sub

    If Worksheets("設定とスタート").CheckBoxes(1).Value = xlOn Then
        BNa = 1
    End If
    If Worksheets("設定とスタート").CheckBoxes(2).Value = xlOn Then
        BNb = 1
    End If
    If BNa = 1 And BNb = 1 Then BNa = 0

If BNa = 1 Then
　　If SAV > 0 Then
   　　　Worksheets("設定とスタート").Range("H13").Copy _
        　　Worksheets(Sn).Range(Cells(2, 21 - tt), Cells(2, 24 - tt))
　　End If
ElseIf BNb = 1 Then
    If SAV > 0 Then
        Worksheets("設定とスタート").Range("I13").Copy _
           Worksheets(Sn).Range(Cells(2, 21 - tt), Cells(2, 24 - tt))
    End If
Else
End If

Sub オールクリアー()
Worksheets("発注資料表").Select
Nrow = Cells(Rows.Count, 13).End(xlUp).Row
       e = Nrow Mod 9
       ee = Nrow \ 9
    If ee = 0 Then
        If e < 3 Then
　　　　　 Worksheets("設定とスタート").Select
          Range("A1").Select
          Exit Sub
        Else
           x = 1
        End If
    Else
        x = ee + 1
    End If
Application.DisplayAlerts = False
If Worksheets.Count <= 3 Then
    Worksheets("発注資料表").Cells.Clear
    With Worksheets("発注資料表")
        .standard.Height
        .StandardWidth
    End With
    'ActiveSheets.Clear
    Application.DisplayAlerts = True
Else
    For s = 1 To x
            Sn = "Ｐ" & s
            Worksheets(Sn).Delete
    Next s
    Application.DisplayAlerts = True

    Worksheets("発注資料表").Cells.Clear
    With Worksheets("発注資料表")
        .Cells.UseStandardHeight = True
        .Cells.UseStandardWidth = True
    End With
End If
Worksheets("設定とスタート").Activate
Range("A1").Select
End Sub