小川慶一さん:

以下のとおりに添削しました。

添削を返送します。

処理全体のロジックはなかなか良くできています。
要改善点は、以下の2点です。
[1] モジュールレベル変数を活用したコードの最適化
[2] 冗長さ排除のためのさらなるアイデア出し

[1]変数Mxは、今の使い方ですと、モジュールレベル変数にする意味がないです
モジュールレベル変数を使う目的は、「複数プロシージャ間での値の受け渡し」です。
が、現状、Mxが登場するのは、あるひとつのモジュール内だけですね。
伝票作成初期に値を入れ、その値の再活用をはかるべきです(コード内でいくつか見本を示しています）

[2]については、添削全体を詳細に検討してください。

以下の方針で再度コーディングし、再提出してください。
変数Mx→最終行はどこ？ということを示す変数としてモジュール全体で活用
変数Ireru→ "B2:B317" とかでなく、"B"など、列のみを指定する変数として活用
変数の使用箇所を調べるには、検索したあと、ダイアログを閉じて[F3]が便利です。

上記意識しつつ、手直しでなく、イチからすべて書き直されることをおすすめします。

Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

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

Private Sub Bangou()
    'wFm.Range("A1").FormulaR1C1 = "No" '並べ替えする表はタイトル行に値を入れましょう。
    wFm.Range("A2").FormulaR1C1 = "1"
    
    '↓整形、いまいちかな。
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False

    '以下のどちらかで行きたい。
'    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
'    wFm.Range("A2:A317").DataSeries _
'        Rowcol:=xlColumns, _
'        Type:=xlLinear, _
'        Date:=xlDay, _
'        Step:=1, _
'        Trend:=False

    'せめて、以下で。(途中改行で続くコードは二段目以降はもう一段インデント)
'    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
'        Type:=xlLinear, Date:=xlDay, _
'        Step:=1, Trend:=False
End Sub

Private Sub Narabe()
    wFm.Sort.SortFields.Clear
    '↓以下は、キレイに整形できていますね
    wFm.Sort.SortFields.Add Key:=wFm.Range(Ireru), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wFm.Sort
'        .SetRange wFm.Range("A1:" & "G" & Mx)
        .SetRange wFm.Range("A1:" & "G" & wFm.Range("G65536").End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'    '↓とはいえ、ここまで整形できるかと。（どこまでやるか？は状況次第ですが）
'    With wFm.Sort
'        .SortFields.Clear
'        .SortFields.Add Key:=wFm.Range(Ireru), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'        .SetRange wFm.Range("A1:" & "G" & wFm.Range("G65536").End(xlUp).Row)
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
    
    '.SortFields.Add はさらに整形
'    With wFm.Sort
'        .SortFields.Clear
'        .SortFields.Add _
'            Key:=wFm.Range(Ireru), _
'            SortOn:=xlSortOnValues, _
'            Order:=xlAscending, _
'            DataOption:=xlSortNormal
'        .SetRange wFm.Range("A1:" & "G" & wFm.Range("G65536").End(xlUp).Row)
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
    
    'さらに言うなら、.SortFields でさらにまとめる。
    'そこまですることの必要性？はともかくとして、ここまでできる。
'    With wFm.Sort
'        With .SortFields
'            .Clear
'            .Add _
'                Key:=wFm.Range(Ireru), _
'                SortOn:=xlSortOnValues, _
'                Order:=xlAscending, _
'                DataOption:=xlSortNormal
'        End With
'        .SetRange wFm.Range("A1:" & "G" & wFm.Range("G65536").End(xlUp).Row)
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
End Sub
Private Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row '"K65536"は、"K" & Rows.Count で。他も同様。
    With Range("B16:K" & Mx)
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub
Private Sub P_hani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Private Sub Daimei()
    '以下についてそろそろ最適解を示します。
    '実は、正解は、「各シートごとに処理を行うためのコードを書く」ではなく、「テンプレートをいじる」です (^^;
    'そうすると、コードも不要になります。高速化できます。
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup

        .CenterHeader = "&F"


        .CenterFooter = "&P / &N ページ"

        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
            End With '←レイアウト崩れ
    Application.PrintCommunication = True
End Sub
Private Sub Tyousei()
    Keisen
    Daimei
    P_hani
    
End Sub

Public Sub Denpyo()
    Application.ScreenUpdating = False
    Dim wTo As Worksheet
    Dim lnMoto As Long
    Dim lnSaki As Long
    Dim dHiduke As Date
    
    Set wFm = Worksheets("main")
    Mx = wFm.Range("B" & Rows.Count).End(xlUp).Row
    WsDelete
    wFm.Activate
    Bangou
'    Ireru = "B2:" & "B" & Mx
    Ireru = "B2:" & "B" & wFm.Range("B65536").End(xlUp).Row
    Narabe
       
'    For lnMoto = 2 To Mx
    For lnMoto = 2 To wFm.Range("B65536").End(xlUp).Row
        If wFm.Range("B" & lnMoto).Value <> wFm.Range("B" & lnMoto - 1).Value Then
            
            If lnMoto > 2 Then
                Tyousei
            End If
            
            lnSaki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & lnMoto).Value
        End If
        dHiduke = wFm.Range("C" & lnMoto).Value
        wTo.Range("B" & lnSaki).Value = Left(Year(dHiduke), 2)
        wTo.Range("C" & lnSaki).Value = Month(dHiduke)
        wTo.Range("D" & lnSaki).Value = Day(dHiduke)
        wTo.Range("E" & lnSaki).Value = wFm.Range("D" & lnMoto).Value
        wTo.Range("F" & lnSaki).Value = wFm.Range("E" & lnMoto).Value
        wTo.Range("H" & lnSaki).Value = wFm.Range("F" & lnMoto).Value
        If wFm.Range("G" & lnMoto).Value > 0 Then
            wTo.Range("I" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        Else
            wTo.Range("J" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        If lnMoto > 2 Then
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value + wTo.Range("K" & lnSaki - 1).Value
        Else
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        lnSaki = lnSaki + 1
    Next
    
    Tyousei
        
    '↓このモジュール前半で Mx = wFm.Range("B" & Rows.Count).End(xlUp).Row としていれば、以下のように書けましたね。
'    Ireru = "A2:" & "A" & Mx
    Ireru = "A2:" & "A" & wFm.Range("A65536").End(xlUp).Row
    Narabe
    
    '以下も、リライトできるはず
'    wFm.Range(Ireru).ClearContents
    wFm.Range("A2:" & "A" & wFm.Range("A65536").End(xlUp).Row).ClearContents
    wFm.Activate
    Application.ScreenUpdating = True
End Sub

2019/07/01 23:39