発展編1 フォローメールセミナー 第11回

この講座は有料講座です。
講座の購入後ご覧になれます。

ログインアカウントの新規作成

解説

発展編1のフォローメールセミナー第11回のフィードバック記入ページです。 <b>【動画はありません】</b>個別ページにて重要事項満載のフォローメールをお読みいただけます。

この教材についての過去の質問・感想

11492 : 小川慶一の回答 (2019-07-01 14:39:35)

小川慶一さん:

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

添削を返送します。

処理全体のロジックはなかなか良くできています。
要改善点は、以下の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


11491 : 小川慶一の回答 (2019-07-01 14:38:26)

受講生の方から、添削依頼を受けました。
以下のものです。

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("A2").FormulaR1C1 = "1"
    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" & 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
    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")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:" & "B" & wFm.Range("B65536").End(xlUp).Row
    Narabe
       
    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
    
    Ireru = "A2:" & "A" & wFm.Range("A65536").End(xlUp).Row
    Narabe
    
    wFm.Range("A2:" & "A" & wFm.Range("A65536").End(xlUp).Row).ClearContents
    wFm.Activate
    Application.ScreenUpdating = True
End Sub


11475 : 小川慶一の回答 (2019-06-24 13:56:24)

参考になれば、と思います。


11474 : 小川慶一の回答 (2019-06-24 13:55:59)

とある受講生の方から、添削依頼をいただきました。
以下に添削を示します。

まずは、いただいたコード。

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

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

Sub Bangou()
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
End Sub

Sub Narabe()
    wFm.Sort.SortFields.Clear
    wFm.Sort.SortFields.Add Key:=Range(Ireru), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wFm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    Range("B16:K" & Mx).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("B16:K" & Mx).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("B16:K" & Mx)
        .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
Sub Phani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Sub Daimei()
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .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
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

Sub Denpyo()
    Dim wTo As Worksheet
    Dim Moto As Long
    Dim Saki As Long
    Dim Hiduke As Long
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:B317"
    Narabe
       
    For Moto = 2 To wFm.Range("B65536").End(xlUp).Row
        If wFm.Range("B" & Moto).Value <> wFm.Range("B" & Moto - 1).Value Then
            
            If Moto > 2 Then
                Keisen
                Daimei
                Phani
            End If
            
            Saki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & Moto).Value
        End If
        Hiduke = wFm.Range("C" & Moto).Value
        wTo.Range("B" & Saki).Value = Left(Year(Hiduke), 2)
        wTo.Range("C" & Saki).Value = Month(Hiduke)
        wTo.Range("D" & Saki).Value = Day(Hiduke)
        wTo.Range("E" & Saki).Value = wFm.Range("D" & Moto).Value
        wTo.Range("F" & Saki).Value = wFm.Range("E" & Moto).Value
        wTo.Range("H" & Saki).Value = wFm.Range("F" & Moto).Value
        If wFm.Range("G" & Moto).Value > 0 Then
            wTo.Range("I" & Saki).Value = wFm.Range("G" & Moto).Value
        Else
            wTo.Range("J" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        If Moto > 2 Then
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value + wTo.Range("K" & Saki - 1).Value
        Else
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        Saki = Saki + 1
    Next
    
    Keisen
    Daimei
    Phani
    
    Ireru = "A2:A317"
    Narabe
    
    wFm.Activate
    wFm.Range("A2:A317").ClearContents
End Sub


そして、以下は、添削内容。

'データ数の増減に耐えられるプログラムにしましょう
'実際にデータ数を増減させて動作確認されると良いかと思います
'「317」という検索キーワードでコード内を検索もしてください
'あと、以下では書いていませんが、SubプロシージャにPublic, Privateキーワードも入れたいですね。
Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

'↓Excellent v(^^*
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

'↓Excellent v(^^*
Sub Bangou()
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
End Sub

Sub Narabe()
    wFm.Sort.SortFields.Clear
    wFm.Sort.SortFields.Add Key:=Range(Ireru), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wFm.Sort
        .SetRange Range("A1:G317") 'データ数可変でもOKになるようになおしましょう
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    '[3] 以下、 With Range("B16:K" & Mx) ... End With で [4] までをくくれるのでは?と。
    '以下の要領。
    'With Range("B16:K" & Mx)
    '    .Borders(xlDiagonalDown).LineStyle = xlNone
    '    .Borders(xlDiagonalUp).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
    
    Range("B16:K" & Mx).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("B16:K" & Mx).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("B16:K" & Mx)
        .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
Sub Phani()
    'Sub Print_Area() のように、間にアンダーバーを入れた名前にするのもありです。VBのキーワードには、アンダーバーが入ったものはないので。
    'アンダーバーを間に入れるなら、簡単な英単語の組み合わせでも安全(VBのキーワードとかぶる心配はない)です
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Sub Daimei()
    '不要と思しきものがかなりありますね。ご自身で設定したものを見出し、それ以外は積極的に削除を!
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .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
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

Sub Denpyo()
    'Application.ScreenUpdating = False '高速化と画面チラツキ防止のため、画面更新を停止
    '↓Moto, Saki, Hidukeは、ハンガリアン記法にしてもいいかも。たとえば、 sMoto, sSaki, dHidukeという変数名で。
    Dim wTo As Worksheet
    Dim Moto As Long
    Dim Saki As Long
    Dim Hiduke As Long
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:B317" '←データ数可変でも動くようになおしたいですね。
    Narabe
       
    For Moto = 2 To wFm.Range("B65536").End(xlUp).Row 'エクセル2007以降のファイル形式で、かつ、データ数が65566件以上ある場合には注意!
        If wFm.Range("B" & Moto).Value <> wFm.Range("B" & Moto - 1).Value Then
            
            If Moto > 2 Then
                '[1]↓Keisen, Daimei, Phani を実行するプロシージャを何か用意してもよいですね。そうすると、[2]での記述も一行で済みます
                Keisen
                Daimei
                Phani
            End If
            
            Saki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & Moto).Value
        End If
        Hiduke = wFm.Range("C" & Moto).Value
        '以下3つは、Format関数を使うこともできます。たとえば直下の行の右辺は、 Format(Fiduke,"yy")
        wTo.Range("B" & Saki).Value = Left(Year(Hiduke), 2)
        wTo.Range("C" & Saki).Value = Month(Hiduke)
        wTo.Range("D" & Saki).Value = Day(Hiduke)
        wTo.Range("E" & Saki).Value = wFm.Range("D" & Moto).Value
        wTo.Range("F" & Saki).Value = wFm.Range("E" & Moto).Value
        wTo.Range("H" & Saki).Value = wFm.Range("F" & Moto).Value
        If wFm.Range("G" & Moto).Value > 0 Then
            wTo.Range("I" & Saki).Value = wFm.Range("G" & Moto).Value
        Else
            wTo.Range("J" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        If Moto > 2 Then
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value + wTo.Range("K" & Saki - 1).Value
        Else
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        Saki = Saki + 1
    Next
    
    '[2]
    Keisen
    Daimei
    Phani
    
    Ireru = "A2:A317"
    Narabe
    
    wFm.Activate
    wFm.Range("A2:A317").ClearContents 'データ数可変でもOKになるようになおしましょう
    Application.ScreenUpdating = True '画面更新を再開
End Sub


11172 : 小川慶一の回答 (2019-02-16 11:56:14)

A.Sさん:

v(^^*

> 小川先生
>
> コメントありがとうございます。
> 並べ替えのマクロを修正しました。
> 引き続き、メールセミナーの受講を行わせていただきます。
> 今後とも、ご指導の程、よろしくお願い致します。
>
>

'「main」シートのB列を昇順に並び替えるマクロ
> Private Sub Narabekae_Torihikisaki()
>     Dim lnMx As Long
>     Dim ws As Worksheet
>     Set ws = Worksheets("main")
>     lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
>     With ws.Sort 'インデント修正
>         .SortFields.Clear
>         .SortFields.Add Key:=Range("B2:B" & lnMx), _
>             SortOn:=xlSortOnValues, _
>             Order:=xlAscending, _
>             DataOption:=xlSortNormal
>         .SetRange Range("A1:G" & lnMx)
>         .Header = xlYes
>         .Apply
>     End With
> End Sub

>
>
'「main」シートのA列を昇順に並び替えるマクロ
> Private Sub Narabekae_No()
>     Dim lnMx As Long
>     Dim ws As Worksheet
>     Set ws = Worksheets("main")
>     lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
>     With ws.Sort 'インデント修正
>         .SortFields.Clear
>         .SortFields.Add Key:=Range("A2:A" & lnMx), _
>             SortOn:=xlSortOnValues, _
>             Order:=xlAscending, _
>             DataOption:=xlSortNormal
>         .SetRange Range("A1:G" & lnMx)
>         .Header = xlYes
>         .Apply
>     End With
> End Sub

>
> > A.Sさん:
> >
> > 拝見しました。
> >
> > もう、ご自身でもおっしゃっていましたが、十分にスキルが身についたのではないか?と思います。
> >
> > 並べ替えのマクロで、最終行が何行目でも動くようになおしましょう。
> > そこだけですね。
> >
> > ひきつづき、マクロの習得、お楽しみください☆
> >
> >
> > > 小川先生
> > >
> > > お忙しい中、添削ありがとうございます。
> > > コメントをいただいた箇所を修正しました。
> > > 再度、恐れ入りますが、ご確認の程、よろしくお願い致します。
> >


11166 : A.Sさんのコメント (2019-02-15 20:21:17)

小川先生

コメントありがとうございます。
並べ替えのマクロを修正しました。
引き続き、メールセミナーの受講を行わせていただきます。
今後とも、ご指導の程、よろしくお願い致します。

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    With ws.Sort 'インデント修正
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B" & lnMx), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange Range("A1:G" & lnMx)
        .Header = xlYes
        .Apply
    End With
End Sub


'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    With ws.Sort 'インデント修正
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & lnMx), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange Range("A1:G" & lnMx)
        .Header = xlYes
        .Apply
    End With
End Sub


> A.Sさん:
>
> 拝見しました。
>
> もう、ご自身でもおっしゃっていましたが、十分にスキルが身についたのではないか?と思います。
>
> 並べ替えのマクロで、最終行が何行目でも動くようになおしましょう。
> そこだけですね。
>
> ひきつづき、マクロの習得、お楽しみください☆
>
>
> > 小川先生
> >
> > お忙しい中、添削ありがとうございます。
> > コメントをいただいた箇所を修正しました。
> > 再度、恐れ入りますが、ご確認の程、よろしくお願い致します。
>


11165 : 小川慶一の回答 (2019-02-15 19:17:14)

A.Sさん:

拝見しました。

もう、ご自身でもおっしゃっていましたが、十分にスキルが身についたのではないか?と思います。

並べ替えのマクロで、最終行が何行目でも動くようになおしましょう。
そこだけですね。

ひきつづき、マクロの習得、お楽しみください☆


> 小川先生
>
> お忙しい中、添削ありがとうございます。
> コメントをいただいた箇所を修正しました。
> 再度、恐れ入りますが、ご確認の程、よろしくお願い致します。


11160 : A.Sさんのコメント (2019-02-14 23:17:28)

小川先生

お忙しい中、添削ありがとうございます。
コメントをいただいた箇所を修正しました。
再度、恐れ入りますが、ご確認の程、よろしくお願い致します。

Public Sub CreateDenpyo()
    DeleteSheets
    Numbering
    Narabekae_Torihikisaki
    Denpyosheet_Set
    Narabekae_No
    NumberingDelete
End Sub


'「main1」シートのページ設定をするマクロ(実行は1回のみ)
Private Sub Template_Setup()
    With Sheets("main1").PageSetup
        .PrintArea = "" '印刷範囲の解除
        .CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
        .CenterFooter = "&P" 'フッターに「ページ番号」を挿入
    End With
    Range("A1").Select
End Sub


'「main」シートのA列に番号を振るマクロ(AutoFill使用)
Private Sub Numbering()
    Dim ln As Long
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    ws.Range("A1").Value = "No."
    lnMx = ws.Range("B" & Rows.Count).End(xlUp).Row
    ws.Range("A2").Value = "2"
    ws.Range("A3").Value = "3"
    ws.Range("A2:A3").AutoFill Destination:=Range("A2:A" & lnMx)
End Sub


'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    With Worksheets("main").Sort 'インデント修正
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B317"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
End Sub


'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    With Worksheets("main").Sort 'インデント修正
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A317"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
End Sub


'取引先毎の伝票シートを作成するマクロ
Private Sub Denpyosheet_Set()
   'DeleteSheetsの削除
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim st As String
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim dt As Date
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Set wsTo = ActiveSheet
            wsTo.Name = st
            lnTo = 16
        End If
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo).Offset(-1).Value
        End If
        dt = wsFm.Range("C" & lnFm).Value
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "m")
        wsTo.Range("D" & lnTo).Value = Format(dt, "d")
        lnTo = lnTo + 1
    Next
    Keisen
End Sub


'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 1) 'インデント修正
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub


11151 : 小川慶一の回答 (2019-02-13 21:43:42)

A.Sさん:

添削を返送します。
びっくりするくらい上達されていますね!

ひきつづき、マクロの学習をお楽しみください☆

Option Explicit

'ひと目見て、できそう!と思わせられるサマリーですね (^^
'各プロシージャ先頭に示された機能のサマリも分かりやすいです。
Sub CreateDenpyo()
    DeleteSheets
    Template_Setup '←これは、プログラムで行わないで、プログラム実行前に手作業でやっておいてもOK。というか、一度すれば再度実行する必要のない作業なので、実は、そうするのが正解です。
    Numbering
    Narabekae_Torihikisaki
    Denpyosheet_Set
    Narabekae_No
    NumberingDelete
End Sub

'「main1」シートのページ設定をするマクロ
Private Sub Template_Setup()
    With Sheets("main1").PageSetup
        .PrintArea = "" '印刷範囲の解除
        .CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
        .CenterFooter = "&P" 'フッターに「ページ番号」を挿入
    End With
    Range("A1").Select
End Sub

'「main」シートのA列に番号を振るマクロ
Private Sub Numbering()
    Dim ln As Long
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    ws.Range("A1").Value = "No."
    'autofillを使った方法も研究してみてください
    lnMx = ws.Range("B" & Rows.Count).End(xlUp).Row
    For ln = 2 To lnMx
        ws.Range("A" & ln).Value = ln
    Next
End Sub

'「main」シートのA列のデータを全て削除するマクロ
Private Sub NumberingDelete()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    ws.Range("A1:A" & lnMx).ClearContents
End Sub

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    '↓インデント不正。withの中身は一段下げる。 _ を使って途中改行している場合も、その行の終わりまでは、一段下げる
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    '↓インデント不正。withの中身は一段下げる。 _ を使って途中改行している場合も、その行の終わりまでは、一段下げる
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'取引先毎の伝票シートを作成するマクロ
Private Sub Denpyosheet_Set()
    DeleteSheets 'Sub CreateDenpyo() の一行目で実行済なので不要ですね
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim st As String
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim dt As Date
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Set wsTo = ActiveSheet
            wsTo.Name = st
            lnTo = 16
        End If
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo).Offset(-1).Value
        End If
        dt = wsFm.Range("C" & lnFm).Value
        '↓format関数の使い方、秀逸です (^^
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "m")
        wsTo.Range("D" & lnTo).Value = Format(dt, "d")
        lnTo = lnTo + 1
    Next
    Keisen
End Sub

'取引先名称シートを削除するマクロ
Public Sub DeleteSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 1)
        '↓以下2行はインデント不正。withの中は一段右へ。
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub


11142 : A.Sさんのコメント (2019-02-13 05:06:07)

小川先生

いつもお世話になっております。
第9回に引き続き、第11回の宿題を提出させていただきます。
お忙しいところ大変恐れ入りますが、添削の程、どうぞよろしくお願い致します。

Sub CreateDenpyo()
    DeleteSheets
    Template_Setup
    Numbering
    Narabekae_Torihikisaki
    Denpyosheet_Set
    Narabekae_No
    NumberingDelete
End Sub

'「main1」シートのページ設定をするマクロ
Private Sub Template_Setup()
    With Sheets("main1").PageSetup
        .PrintArea = "" '印刷範囲の解除
        .CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
        .CenterFooter = "&P" 'フッターに「ページ番号」を挿入
    End With
    Range("A1").Select
End Sub

'「main」シートのA列に番号を振るマクロ
Private Sub Numbering()
    Dim ln As Long
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    ws.Range("A1").Value = "No."
    lnMx = ws.Range("B" & Rows.Count).End(xlUp).Row
    For ln = 2 To lnMx
        ws.Range("A" & ln).Value = ln
    Next
End Sub

'「main」シートのA列のデータを全て削除するマクロ
Private Sub NumberingDelete()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    ws.Range("A1:A" & lnMx).ClearContents
End Sub

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'取引先毎の伝票シートを作成するマクロ
Private Sub Denpyosheet_Set()
    DeleteSheets
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim st As String
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim dt As Date
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Set wsTo = ActiveSheet
            wsTo.Name = st
            lnTo = 16
        End If
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo).Offset(-1).Value
        End If
        dt = wsFm.Range("C" & lnFm).Value
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "m")
        wsTo.Range("D" & lnTo).Value = Format(dt, "d")
        lnTo = lnTo + 1
    Next
    Keisen
End Sub

'取引先名称シートを削除するマクロ
Public Sub DeleteSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 1)
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub


10646 : 小川慶一の回答 (2018-10-11 07:17:08)

わかやまさん:

おはようございます。

Sub heda()
With Worksheets("main1").PageSetup
.CenterHeader = "伝票"
.CenterFooter = Date
End With
End Sub[/code]

も不要です。

プログラムで手直しするのではなく、プログラム実行前に、手作業でワークシート「main1」にヘッダーフッターを入れます。
そうすると、このプログラムを書くことも、このプログラムをを書くための調査も不要になります。


> 小川様
>
> 添削ありがとうございました。
> テンプレートのヘッダーフッターを修正しているつもりなのですが、どの部分がおかしいでしょうか?
> どうぞよろしくお願いします。


10645 : わかやまさんのコメント (2018-10-11 05:39:01)

小川様

添削ありがとうございました。
テンプレートのヘッダーフッターを修正しているつもりなのですが、どの部分がおかしいでしょうか?
どうぞよろしくお願いします。


10639 : 小川慶一の回答 (2018-10-10 11:20:04)

わかやまさん:

Sub heda() の中身、よく調べられましたね。
このコードでも良いのですが、最善策は、「テンプレートのヘッダーフッターを修正する」でした。そのほうが簡単です。



> 小川様 
>
> 添削よろしくお願いいたします。
>
>

Sub ikkini()
>     sort1
>     hontai
>     sort2
> End Sub

>
>
Sub sort1()
>     Dim cSaigo As Long
>     cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
>     Worksheets("main").Sort.SortFields.Clear
>     Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("B2:B" & cSaigo), _
>         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal  'ワークシートを指定しました
>     With Worksheets("main").Sort
>         .SetRange Range("A1:G" & cSaigo)
>         .Header = xlYes
>         .Apply
>     End With
>     Worksheets("main").Range("A1").Value = "No."
>     Worksheets("main").Range("A2").Value = 1
>     Worksheets("main").Range("A2").AutoFill Destination:=Worksheets("main").Range("A2:A" & cSaigo), Type:=xlLinearTrend 'ワークシートを指定しました
>     heda 'ヘッダーとフッターの設定
> End Sub

>
>
Sub sort2()
>     Dim cSaigo As Long
>     cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
>     Worksheets("main").Sort.SortFields.Clear
>     Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("A2:A" & cSaigo), _
>         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'ワークシートを指定しました
>     With Worksheets("main").Sort
>         .SetRange Range("A1:G" & cSaigo)
>         .Header = xlYes
>         .Apply
>     End With
> End Sub

>
>
Sub syokyo()
>     Dim ws As Worksheet
>     For Each ws In Worksheets
>         Application.DisplayAlerts = False
>         If Left(ws.Name, 4) <> "main" Then 'Left関数を用いました!
>             ws.Delete
>         End If
>         Application.DisplayAlerts = True
>     Next
> End Sub

>
>
Sub hontai()
>     syokyo
>     Dim cGyo As Long
>     Dim cSaigo As Long
>     Dim wsMain As Worksheet
>     Dim wsNow As Worksheet
>     Dim sGyosya As String
>     Dim dDate As Date
>     Dim cSaki As Long
>     Set wsMain = Worksheets("main")
>     cSaigo = wsMain.Range("B" & Rows.Count).End(xlUp).Row
>     For cGyo = 2 To cSaigo
>         If sGyosya <> wsMain.Range("B" & cGyo).Value Then
>             If cGyo > 2 Then
>                 keisen2
>             End If
>             Sheets("main1").Copy After:=Sheets(Worksheets.Count)
>             Sheets("main1 (2)").Name = wsMain.Range("B" & cGyo).Value
>             Set wsNow = ActiveSheet
>             sGyosya = wsNow.Name
>             cSaki = 16
>         End If
>         wsNow.Range("F2").Value = wsNow.Name
>         wsNow.Range("H" & cSaki).Value = wsMain.Range("F" & cGyo).Value
>         wsNow.Range("F" & cSaki).Value = wsMain.Range("E" & cGyo).Value
>         wsNow.Range("E" & cSaki).Value = wsMain.Range("D" & cGyo).Value
>         dDate = wsMain.Range("C" & cGyo).Value
>         wsNow.Range("B" & cSaki).Value = Format(dDate, "yy")
>         wsNow.Range("C" & cSaki).Value = Format(dDate, "mm")
>         wsNow.Range("D" & cSaki).Value = Format(dDate, "dd")
>         If wsMain.Range("G" & cGyo) > 0 Then
>             wsNow.Range("I" & cSaki).Value = wsMain.Range("G" & cGyo).Value
>         ElseIf wsMain.Range("G" & cGyo) < 0 Then
>             wsNow.Range("J" & cSaki).Value = wsMain.Range("G" & cGyo).Value
>         End If
>         If cSaki = 16 Then
>             wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value
>         Else
>             wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value + wsNow.Range("K" & cSaki - 1)
>         End If
>         cSaki = cSaki + 1
>     Next
>     keisen2
> End Sub

>
>
Sub keisen2() 'ネットで調べ、シンプルにしました。同じ動作にはなっております。
>     Dim cSaigo As Long
>     Dim wsNow As Worksheet
>     Set wsNow = ActiveSheet
>     cSaigo = wsNow.Range("B" & Rows.Count).End(xlUp).Row
>     wsNow.Range("B16:K" & cSaigo).Borders.LineStyle = xlContinuous
> End Sub

>
>
Sub heda()
>     With Worksheets("main1").PageSetup
>         .CenterHeader = "伝票"
>         .CenterFooter = Date
>     End With
> End Sub

>


10630 : わかやまさんのコメント (2018-10-06 06:40:04)

小川様 

添削よろしくお願いいたします。

Sub ikkini()
    sort1
    hontai
    sort2
End Sub


Sub sort1()
    Dim cSaigo As Long
    cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Worksheets("main").Sort.SortFields.Clear
    Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("B2:B" & cSaigo), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal  'ワークシートを指定しました
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & cSaigo)
        .Header = xlYes
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No."
    Worksheets("main").Range("A2").Value = 1
    Worksheets("main").Range("A2").AutoFill Destination:=Worksheets("main").Range("A2:A" & cSaigo), Type:=xlLinearTrend 'ワークシートを指定しました
    heda 'ヘッダーとフッターの設定
End Sub


Sub sort2()
    Dim cSaigo As Long
    cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Worksheets("main").Sort.SortFields.Clear
    Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("A2:A" & cSaigo), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'ワークシートを指定しました
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & cSaigo)
        .Header = xlYes
        .Apply
    End With
End Sub


Sub syokyo()
    Dim ws As Worksheet
    For Each ws In Worksheets
        Application.DisplayAlerts = False
        If Left(ws.Name, 4) <> "main" Then 'Left関数を用いました!
            ws.Delete
        End If
        Application.DisplayAlerts = True
    Next
End Sub


Sub hontai()
    syokyo
    Dim cGyo As Long
    Dim cSaigo As Long
    Dim wsMain As Worksheet
    Dim wsNow As Worksheet
    Dim sGyosya As String
    Dim dDate As Date
    Dim cSaki As Long
    Set wsMain = Worksheets("main")
    cSaigo = wsMain.Range("B" & Rows.Count).End(xlUp).Row
    For cGyo = 2 To cSaigo
        If sGyosya <> wsMain.Range("B" & cGyo).Value Then
            If cGyo > 2 Then
                keisen2
            End If
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Sheets("main1 (2)").Name = wsMain.Range("B" & cGyo).Value
            Set wsNow = ActiveSheet
            sGyosya = wsNow.Name
            cSaki = 16
        End If
        wsNow.Range("F2").Value = wsNow.Name
        wsNow.Range("H" & cSaki).Value = wsMain.Range("F" & cGyo).Value
        wsNow.Range("F" & cSaki).Value = wsMain.Range("E" & cGyo).Value
        wsNow.Range("E" & cSaki).Value = wsMain.Range("D" & cGyo).Value
        dDate = wsMain.Range("C" & cGyo).Value
        wsNow.Range("B" & cSaki).Value = Format(dDate, "yy")
        wsNow.Range("C" & cSaki).Value = Format(dDate, "mm")
        wsNow.Range("D" & cSaki).Value = Format(dDate, "dd")
        If wsMain.Range("G" & cGyo) > 0 Then
            wsNow.Range("I" & cSaki).Value = wsMain.Range("G" & cGyo).Value
        ElseIf wsMain.Range("G" & cGyo) < 0 Then
            wsNow.Range("J" & cSaki).Value = wsMain.Range("G" & cGyo).Value
        End If
        If cSaki = 16 Then
            wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value
        Else
            wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value + wsNow.Range("K" & cSaki - 1)
        End If
        cSaki = cSaki + 1
    Next
    keisen2
End Sub


Sub keisen2() 'ネットで調べ、シンプルにしました。同じ動作にはなっております。
    Dim cSaigo As Long
    Dim wsNow As Worksheet
    Set wsNow = ActiveSheet
    cSaigo = wsNow.Range("B" & Rows.Count).End(xlUp).Row
    wsNow.Range("B16:K" & cSaigo).Borders.LineStyle = xlContinuous
End Sub


Sub heda()
    With Worksheets("main1").PageSetup
        .CenterHeader = "伝票"
        .CenterFooter = Date
    End With
End Sub


10485 : 小川慶一の回答 (2018-08-22 14:46:20)

マメコトさん:

> やはりひとつひとつ意味を調べるべきなのでしょうか。

半分とりはずして実行してみる→結果を見てみる。だめなら戻して別の半分をとりはずして実行してみる、...という過程でまずはテストをくり返すことです。



> お世話になっております。
>

Sub Denpyou()
>     Call Sort_First
>     Call Delete_Sheets
>     Call Create_Denpyou
>     Call Sort_End
> End Sub

> という伝票作成マクロの、Create_Denpyouの中にCreate_Keisenを作り、そのCreate_Keisenの最後に印刷に関するコードを書きました。
> ・・・とは言え、マクロの記録のどこを削れば良いのかわかりませんでした。
Private Sub Create_Keisen()

    Dim nGyou As Long
    
    nGyou = Range("E" & Rows.Count).End(xlUp).Row
    
    Range("B16:K" & nGyou).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$15"
        .PrintTitleColumns = ""
    End With
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .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
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = True
End Sub

> やはりひとつひとつ意味を調べるべきなのでしょうか。


10472 : マメコトさんのコメント (2018-08-21 21:32:27)

お世話になっております。

Sub Denpyou()
    Call Sort_First
    Call Delete_Sheets
    Call Create_Denpyou
    Call Sort_End
End Sub

という伝票作成マクロの、Create_Denpyouの中にCreate_Keisenを作り、そのCreate_Keisenの最後に印刷に関するコードを書きました。
・・・とは言え、マクロの記録のどこを削れば良いのかわかりませんでした。
Private Sub Create_Keisen()

    Dim nGyou As Long
    
    nGyou = Range("E" & Rows.Count).End(xlUp).Row
    
    Range("B16:K" & nGyou).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$15"
        .PrintTitleColumns = ""
    End With
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .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
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = True
End Sub

やはりひとつひとつ意味を調べるべきなのでしょうか。


9904 : 小川慶一の回答 (2018-05-04 10:41:43)

受講生 さん:

> コメントずれの原因は、当方のフォントがMeiryo UIを使用しているからだと思われます。
> しかしながら、そのデメリットを差し置いても、見やすさ(好み)優先でMeiryo UIを使用している次第です。

僕としては、等幅フォントを使っていただきたいですね…。
というのは、等幅フォントだと、「形の認識」がより容易だからです。

「見やすさ」の定義が、僕と違うかもしれません。
「見やすさ」を決める要素にもいろいろあります。

そのうち、以下では、「形の認識」に注目してみたいと思います。

以下の比較図を見てみてください。
左側のものと右側のものでは、Visual Basic Editorにコードを表示するときに使っているフォントが異なります。
https://www.dropbox.com/s/jsu3vvrmh2ewhac/font_hikaku.JPG?dl=0

左側は等幅フォントです。MS 明朝 (日本語)です。
右側は等幅フォントではありません。MS P明朝 (日本語)です。

プログラム内の青でくくった部分(上と下)を見てみてください。

同じ文字数という「韻を踏んだ形」で表現したものがどう表示されているか?というと、左側の等幅フォントのものでは同じ形状で表現されていますが、右側のものでは形が崩れていますね。

左側の状態であれば、右側の状態のときに比べて、何か問題があったときのテストに手間がかかりません。
左側の状態であれば、同じような形状のプログラムが連続するところについては、パッと形を見ただけで、うまく書けているかどうか?ということを判定できます。
一方、右側の状態だと、各行を個別にしっかり読まないと、このブロック内の各行がきちんとをかけているか?ということを確認できません。

この差は、蓄積すると、テストにかかる負荷をかなり変えます。

確かに、「文字の認識」という意味ではプログラミング用に好適な等幅フォントよりも良いものもあるかもしれません。
初心者の頃であれば、一行一行のプログラムの中身をしっかり書く能力が不足しているので各行の読みやすさが重視されるかもしれません。
「全体の構造に意識を向けつつコードを書く」といったことが要求される規模のプログラムは書きませんし、そういう意味でも、こういう視点は不要だったかもしれません。

しかし、プログラミング中上級者にとって大切なのは、全体の形に対するパターン認識のしやすさです。
「形の認識」か?「文字の認識」か?ということであれば、「形の認識」がより容易な等幅フォントの方が優れているかと僕は思います。


9894 : 受講生さんのコメント (2018-05-02 10:37:18)

小川慶一さん:
コメントずれの原因は、当方のフォントがMeiryo UIを使用しているからだと思われます。
好みの問題かもしれませんが、Windows7の標準フォントで、当方が勤務する会社でも、Office文書やメールで多くの社員が好んで使っております。
それだけ、見やすいと指示されているからだと考えます。
MSゴシックなどの等幅フォントは、Meiryo UIと比較すると、どうもしても見にくくで好きになれません。
確かにデメリットはあります。
横に長いマクロのプログラムになると、カーソルの位置と文字の位置がズレて合わなくなります。
しかしながら、そのデメリットを差し置いても、見やすさ(好み)優先でMeiryo UIを使用している次第です。
この件に関しましては、どうぞご勘弁いただきたく存じます。

> 受講生 さん:
>
> こんにちは。
>
> 以下に添削したファイルを置きました。
> https://www.dropbox.com/sh/eagelyr9zvp7ybi/AAC2iQw77K1fHRP5aGvtOhjWa?dl=0
>
> comment_soft1.JPG, chuban.JPG のコメントの非整列ぶりが気になります。
> たとえば、 comment_soft1.JPG は、 comment_soft2.JPG の下の方のサンプルのように、揃え方ほうが可読性が増します。
> VBEのフォントは等幅フォントを使いましょう。たとえば、MSゴシック等。
>
> ひきつづき、よい休日を (^^)/~
>
>
>

Option Explicit
> 'この位置に下各プロシージャに共通する変数をモジュールレベル変数として宣言しておりましたが
> '個々のプロシージャ内で都度変数を宣言すべきとのご指導をいただき削除いたしました。
> 
> Sub control_all()
> '各コメントの文頭にに----や…をつけいていましたが
> '不要では?とのご指摘に削除して、文頭を揃えました。
> 
>     delete_sheets      '伝票フォーマットを全て削除 ← 元々はdenpyo_sakuseiに入れておりました。
>     A_retu_number   'mainのA列に№付け
>     sort_torihikisaki   '取引先名称で並べ替え
>     denpyo_sakusei   'シート作成とデータ貼り付け
>     sort_number        '№で並べ替え
>     
> End Sub
> Sub delete_sheets()     '伝票フォーマットを全て削除
>     
>     Application.DisplayAlerts = False   '警告解除
>     
>     Dim Ws As Worksheet
>     For Each Ws In Worksheets
>         If Left(Ws.Name, 4) &lt;> "main" Then
>             Ws.Delete
>         End If
>     Next
>     
>     Application.DisplayAlerts = True    '警告設定
> 
> End Sub
> Sub denpyo_sakusei()    'シート作成とデータ貼り付け
>     
> 'この行にdelete_sheetsを入れておりましたが、control_allに
> '入れるべきと判断したため、移動しました。
> 
>     Dim DSheet As Worksheet
>     Dim FSheet As Worksheet
>     Set DSheet = Worksheets("main")
>     Set FSheet = Worksheets("main1")
>     
>     Dim Gyo As Long
>     Dim sGyo As Long 'sが先頭に来ると、ハンガリアン記法的には「データ型は文字列」という意味になりますね。 ogawa
>     Dim mxGyo As Long
>     Dim Masyo As String
>     Dim PSheet As Worksheet
>     
>     mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
>     
>     Application.ScreenUpdating = False  '画面更新停止
>     For Gyo = 2 To mxGyo
>         If Masyo &lt;> DSheet.Range("B" & Gyo).Value Then
>             Masyo = DSheet.Range("B" & Gyo).Value
>             FSheet.Copy After:=DSheet
>             Worksheets("main1 (2)").Name = Masyo
>             Set PSheet = ActiveSheet
>             PSheet.Name = Masyo
>             sGyo = 16
>         End If
>         '↓以下3行は、 format関数を使うことも試してください ogawa
>         PSheet.Range("B" & sGyo).Value = Right(Year(DSheet.Range("C" & Gyo).Value), 2)  '年
>         PSheet.Range("C" & sGyo).Value = Month(DSheet.Range("C" & Gyo).Value)               '月
>         PSheet.Range("D" & sGyo).Value = Day(DSheet.Range("C" & Gyo).Value)                   '日
>         PSheet.Range("E" & sGyo).Value = DSheet.Range("D" & Gyo).Value                            '会計番号
>         PSheet.Range("F" & sGyo).Value = DSheet.Range("E" & Gyo).Value                             '伝票番号
>         PSheet.Range("H" & sGyo).Value = DSheet.Range("F" & Gyo).Value                             '取引詳細
>         
>         If DSheet.Range("G" & Gyo).Value >= 0 Then
>             PSheet.Range("I" & sGyo).Value = DSheet.Range("G" & Gyo).Value                          '借方金額
>         Else
>             PSheet.Range("J" & sGyo).Value = DSheet.Range("G" & Gyo).Value                          '貸方金額
>         End If
>         
>         If sGyo = 16 Then   '残高計算
>             PSheet.Range("K" & sGyo).Value = DSheet.Range("G" & Gyo).Value
>         Else
>             PSheet.Range("K" & sGyo).Value = DSheet.Range("G" & Gyo).Value _
>             + DSheet.Range("G" & Gyo).Offset(-1).Value
>         End If
>         
>         PSheet.Range("F2").Value = PSheet.Name & " 実績"   '実績タイトル
>         sGyo = sGyo + 1
>     Next
>     
>     lines_setting   '罫線を引く ←これでも悪くはないですが、罫線を引くタイミングを、「各シートでの処理が終わり、次のシートでの処理を開始する直前」にしてやってみましょう。 ogawa
>     Application.ScreenUpdating = True   '画面更新設定
>     
>     DSheet.Activate
> 
> End Sub
> Sub A_retu_number()     'mainのA列にNo.付け
>     Dim DSheet As Worksheet
>     Set DSheet = Worksheets("main")
> 
> '№欄設定
>     DSheet.Range("A1").Value = "No."
>     DSheet.Range("A1").Interior.ColorIndex = 35
>     DSheet.Range("A1").HorizontalAlignment = xlCenter
>     DSheet.Range("A1").Font.Bold = True
> 
> '№付け
>     '↓autofillを使った入力方法も調べて実装してみてください。 ogawa
>     Dim Gyo As Long
>     Dim mxGyo As Long
>     mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
>     For Gyo = 2 To mxGyo
>         If Gyo = 2 Then
>             DSheet.Range("A" & Gyo).Value = "1"
>         Else
>             DSheet.Range("A" & Gyo).Value = DSheet.Range("A" & Gyo).Offset(-1).Value + 1
>         End If
>     Next
>     
> End Sub
> Sub sort_torihikisaki()     '取引先名称で並べ替え
>     Dim DSheet As Worksheet
>     Set DSheet = Worksheets("main")
>     
>     Dim mxGyo As Long
>     mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
>     
>     DSheet.Range("A1:G" & mxGyo).Sort _
>         Key1:=DSheet.Range("B1"), _
>         Order1:=xlAscending, _
>         Header:=xlYes
> 
> End Sub
> Sub sort_number()   'No.で並べ替え
>     Dim DSheet As Worksheet
>     Set DSheet = Worksheets("main")
>     
>     Dim mxGyo As Long
>     mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
>     
>     DSheet.Range("A1:G" & mxGyo).Sort _
>         Key1:=DSheet.Range("A1"), _
>         Order1:=xlAscending, _
>         Header:=xlYes
> 
> End Sub
> Sub lines_setting()  '罫線を引く
> 'データの件数分だけ罫線を引く作業するというのは非効率です…とのご指摘を受けて
> 'denpyo_sakusei内のfor~next構文の中に入れていたのを、シート単位で
> '罫線作成するように、lines_settingを追加しました。
> 
>     Dim Ws As Worksheet
>     Dim mxGyo As Long
>     For Each Ws In Worksheets
>         If Left(Ws.Name, 4) &lt;> "main" Then
>             Ws.Activate
>             mxGyo = Range("B" & Rows.Count).End(xlUp).Row
>             Range("B" & 16 & ":K" & mxGyo + 1).Borders.LineStyle = True '罫線を引く
>         End If
>     Next
> 
> End Sub

>
> > 小川慶一さん:
> > GW中のまとまった時間がとれる間に、極力セミナーを進行させたく、少々勇み足でした。
> > 第9回でご指導いただきました内容で修正し、どのように修正したのか、コメントをつけて提出いたします。
> >
> > > 受講生 さん:
> > >
> > > ざっと拝見しました。
> > >
> > > 前回ご返送した第9回の回答9856の方を先に解決しましょう。
> > > https://online.pc5bai.com/Movie/index/30/244
> > >
> > > ご返送した前作の内容をどの程度理解したのか?添削の中で僕が指摘したことをあえて外すのならばそれはなぜなのか?
> > > 他にどんなやり方があるかといったことについてどの程度検討したのか?といったところについてわからないと、コメントしようがありません。
> > >
> > > よく似た課題を出しているのは、一度しっかり添削を受けてその内容と比較した上で再度この課題にイチから着手して欲しいからです。
> > > 受講生さんにとって一番力になる方法でアドバイスしたいと思っています。
> > >
> > > よろしくお願いします。
> > >
> > > > 第11回セミナーの宿題を提出いたします。
> > > > ご査収下さい。


9876 : 小川慶一の回答 (2018-04-30 16:41:27)

受講生 さん:

こんにちは。

以下に添削したファイルを置きました。
https://www.dropbox.com/sh/eagelyr9zvp7ybi/AAC2iQw77K1fHRP5aGvtOhjWa?dl=0

comment_soft1.JPG, chuban.JPG のコメントの非整列ぶりが気になります。
たとえば、 comment_soft1.JPG は、 comment_soft2.JPG の下の方のサンプルのように、揃え方ほうが可読性が増します。
VBEのフォントは等幅フォントを使いましょう。たとえば、MSゴシック等。

ひきつづき、よい休日を (^^)/~


Option Explicit
'この位置に下各プロシージャに共通する変数をモジュールレベル変数として宣言しておりましたが
'個々のプロシージャ内で都度変数を宣言すべきとのご指導をいただき削除いたしました。

Sub control_all()
'各コメントの文頭にに----や…をつけいていましたが
'不要では?とのご指摘に削除して、文頭を揃えました。

    delete_sheets      '伝票フォーマットを全て削除 ← 元々はdenpyo_sakuseiに入れておりました。
    A_retu_number   'mainのA列に№付け
    sort_torihikisaki   '取引先名称で並べ替え
    denpyo_sakusei   'シート作成とデータ貼り付け
    sort_number        '№で並べ替え
    
End Sub
Sub delete_sheets()     '伝票フォーマットを全て削除
    
    Application.DisplayAlerts = False   '警告解除
    
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        If Left(Ws.Name, 4) <> "main" Then
            Ws.Delete
        End If
    Next
    
    Application.DisplayAlerts = True    '警告設定

End Sub
Sub denpyo_sakusei()    'シート作成とデータ貼り付け
    
'この行にdelete_sheetsを入れておりましたが、control_allに
'入れるべきと判断したため、移動しました。

    Dim DSheet As Worksheet
    Dim FSheet As Worksheet
    Set DSheet = Worksheets("main")
    Set FSheet = Worksheets("main1")
    
    Dim Gyo As Long
    Dim sGyo As Long 'sが先頭に来ると、ハンガリアン記法的には「データ型は文字列」という意味になりますね。 ogawa
    Dim mxGyo As Long
    Dim Masyo As String
    Dim PSheet As Worksheet
    
    mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    Application.ScreenUpdating = False  '画面更新停止
    For Gyo = 2 To mxGyo
        If Masyo <> DSheet.Range("B" & Gyo).Value Then
            Masyo = DSheet.Range("B" & Gyo).Value
            FSheet.Copy After:=DSheet
            Worksheets("main1 (2)").Name = Masyo
            Set PSheet = ActiveSheet
            PSheet.Name = Masyo
            sGyo = 16
        End If
        '↓以下3行は、 format関数を使うことも試してください ogawa
        PSheet.Range("B" & sGyo).Value = Right(Year(DSheet.Range("C" & Gyo).Value), 2)  '年
        PSheet.Range("C" & sGyo).Value = Month(DSheet.Range("C" & Gyo).Value)               '月
        PSheet.Range("D" & sGyo).Value = Day(DSheet.Range("C" & Gyo).Value)                   '日
        PSheet.Range("E" & sGyo).Value = DSheet.Range("D" & Gyo).Value                            '会計番号
        PSheet.Range("F" & sGyo).Value = DSheet.Range("E" & Gyo).Value                             '伝票番号
        PSheet.Range("H" & sGyo).Value = DSheet.Range("F" & Gyo).Value                             '取引詳細
        
        If DSheet.Range("G" & Gyo).Value >= 0 Then
            PSheet.Range("I" & sGyo).Value = DSheet.Range("G" & Gyo).Value                          '借方金額
        Else
            PSheet.Range("J" & sGyo).Value = DSheet.Range("G" & Gyo).Value                          '貸方金額
        End If
        
        If sGyo = 16 Then   '残高計算
            PSheet.Range("K" & sGyo).Value = DSheet.Range("G" & Gyo).Value
        Else
            PSheet.Range("K" & sGyo).Value = DSheet.Range("G" & Gyo).Value _
            + DSheet.Range("G" & Gyo).Offset(-1).Value
        End If
        
        PSheet.Range("F2").Value = PSheet.Name & " 実績"   '実績タイトル
        sGyo = sGyo + 1
    Next
    
    lines_setting   '罫線を引く ←これでも悪くはないですが、罫線を引くタイミングを、「各シートでの処理が終わり、次のシートでの処理を開始する直前」にしてやってみましょう。 ogawa
    Application.ScreenUpdating = True   '画面更新設定
    
    DSheet.Activate

End Sub
Sub A_retu_number()     'mainのA列にNo.付け
    Dim DSheet As Worksheet
    Set DSheet = Worksheets("main")

'№欄設定
    DSheet.Range("A1").Value = "No."
    DSheet.Range("A1").Interior.ColorIndex = 35
    DSheet.Range("A1").HorizontalAlignment = xlCenter
    DSheet.Range("A1").Font.Bold = True

'№付け
    '↓autofillを使った入力方法も調べて実装してみてください。 ogawa
    Dim Gyo As Long
    Dim mxGyo As Long
    mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
    For Gyo = 2 To mxGyo
        If Gyo = 2 Then
            DSheet.Range("A" & Gyo).Value = "1"
        Else
            DSheet.Range("A" & Gyo).Value = DSheet.Range("A" & Gyo).Offset(-1).Value + 1
        End If
    Next
    
End Sub
Sub sort_torihikisaki()     '取引先名称で並べ替え
    Dim DSheet As Worksheet
    Set DSheet = Worksheets("main")
    
    Dim mxGyo As Long
    mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    DSheet.Range("A1:G" & mxGyo).Sort _
        Key1:=DSheet.Range("B1"), _
        Order1:=xlAscending, _
        Header:=xlYes

End Sub
Sub sort_number()   'No.で並べ替え
    Dim DSheet As Worksheet
    Set DSheet = Worksheets("main")
    
    Dim mxGyo As Long
    mxGyo = DSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    DSheet.Range("A1:G" & mxGyo).Sort _
        Key1:=DSheet.Range("A1"), _
        Order1:=xlAscending, _
        Header:=xlYes

End Sub
Sub lines_setting()  '罫線を引く
'データの件数分だけ罫線を引く作業するというのは非効率です…とのご指摘を受けて
'denpyo_sakusei内のfor~next構文の中に入れていたのを、シート単位で
'罫線作成するように、lines_settingを追加しました。

    Dim Ws As Worksheet
    Dim mxGyo As Long
    For Each Ws In Worksheets
        If Left(Ws.Name, 4) <> "main" Then
            Ws.Activate
            mxGyo = Range("B" & Rows.Count).End(xlUp).Row
            Range("B" & 16 & ":K" & mxGyo + 1).Borders.LineStyle = True '罫線を引く
        End If
    Next

End Sub


> 小川慶一さん:
> GW中のまとまった時間がとれる間に、極力セミナーを進行させたく、少々勇み足でした。
> 第9回でご指導いただきました内容で修正し、どのように修正したのか、コメントをつけて提出いたします。
>
> > 受講生 さん:
> >
> > ざっと拝見しました。
> >
> > 前回ご返送した第9回の回答9856の方を先に解決しましょう。
> > https://online.pc5bai.com/Movie/index/30/244
> >
> > ご返送した前作の内容をどの程度理解したのか?添削の中で僕が指摘したことをあえて外すのならばそれはなぜなのか?
> > 他にどんなやり方があるかといったことについてどの程度検討したのか?といったところについてわからないと、コメントしようがありません。
> >
> > よく似た課題を出しているのは、一度しっかり添削を受けてその内容と比較した上で再度この課題にイチから着手して欲しいからです。
> > 受講生さんにとって一番力になる方法でアドバイスしたいと思っています。
> >
> > よろしくお願いします。
> >
> > > 第11回セミナーの宿題を提出いたします。
> > > ご査収下さい。


9875 : 受講生さんのコメント (2018-04-30 15:07:55)

小川慶一さん:
GW中のまとまった時間がとれる間に、極力セミナーを進行させたく、少々勇み足でした。
第9回でご指導いただきました内容で修正し、どのように修正したのか、コメントをつけて提出いたします。

> 受講生 さん:
>
> ざっと拝見しました。
>
> 前回ご返送した第9回の回答9856の方を先に解決しましょう。
> https://online.pc5bai.com/Movie/index/30/244
>
> ご返送した前作の内容をどの程度理解したのか?添削の中で僕が指摘したことをあえて外すのならばそれはなぜなのか?
> 他にどんなやり方があるかといったことについてどの程度検討したのか?といったところについてわからないと、コメントしようがありません。
>
> よく似た課題を出しているのは、一度しっかり添削を受けてその内容と比較した上で再度この課題にイチから着手して欲しいからです。
> 受講生さんにとって一番力になる方法でアドバイスしたいと思っています。
>
> よろしくお願いします。
>
> > 第11回セミナーの宿題を提出いたします。
> > ご査収下さい。


9866 : 小川慶一の回答 (2018-04-30 12:34:19)

受講生 さん:

ざっと拝見しました。

前回ご返送した第9回の回答9856の方を先に解決しましょう。
https://online.pc5bai.com/Movie/index/30/244

ご返送した前作の内容をどの程度理解したのか?添削の中で僕が指摘したことをあえて外すのならばそれはなぜなのか?
他にどんなやり方があるかといったことについてどの程度検討したのか?といったところについてわからないと、コメントしようがありません。

よく似た課題を出しているのは、一度しっかり添削を受けてその内容と比較した上で再度この課題にイチから着手して欲しいからです。
受講生さんにとって一番力になる方法でアドバイスしたいと思っています。

よろしくお願いします。

> 第11回セミナーの宿題を提出いたします。
> ご査収下さい。


9857 : 受講生さんのコメント (2018-04-27 16:08:14)

第11回セミナーの宿題を提出いたします。
ご査収下さい。


9487 : 小川慶一の回答 (2018-02-27 00:32:13)

添削を返送します。今回、イチから書かれました?
ここらでイチから書いてみるとまたよい学びになるかと。

Option Explicit

Dim moto As Long    '転記元行番号
Dim saki As Long    '転記先行番号
Public sheet_num As Long   'フッダー用のシート番号

Sub main()  'メインの実行プロシージャ
    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort 'name_sortで指摘した問題は、こちらでも直しましょう(^^; ogawa
    num_del
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)

    Dim w As Worksheet

    For Each w In Worksheets
        Select Case w.Name
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
     
    Range("A2").Value = "1"    'AutoFillによる番号の割り当て
    Range("A2").AutoFill Destination:=Range("A2:A" & LastNum), Type:=xlFillSeries
End Sub
 
Sub name_sort()     '名称で並べ替え
 
    Worksheets("main").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Sub Create_Voucher() 'シート作成用
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
    
    Dim shTo As Worksheet 'ogawa
    sheet_num = 1
     
    For moto = 2 To LastNum
                                     
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                Call header_footer                                       'ヘッダーフッダーの作成を行う
            End If
            saki = 16                                                    '転送先の行番号を初期化する
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
            Set shTo = Worksheets(name_bk) 'ogawa
        End If
         
'        Call tenki_kingaku
        Call tenki_kingaku_ogawa(shTo)
        saki = saki + 1
    Next
    Call keisen                                                  '最終行書込み後、罫線を引く
    Call header_footer                                           'ヘッダーフッダーの作成を行う
End Sub
  
Sub tenki_kingaku_ogawa(wto As Worksheet)
 
    Dim wFm As Worksheet
    Set wFm = Worksheets("main")
 
    wto.Range("B" & saki).Value = Format((wFm.Range("C" & moto).Value), "yy")
    wto.Range("C" & saki).Value = Format(wFm.Range("C" & moto).Value, "m")
    wto.Range("D" & saki).Value = Format(wFm.Range("C" & moto).Value, "d")
    wto.Range("E" & saki).Value = wFm.Range("D" & moto).Value
    wto.Range("F" & saki).Value = wFm.Range("E" & moto).Value
    wto.Range("H" & saki).Value = wFm.Range("F" & moto).Value
    
    If wFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        wto.Range("I" & saki).Value = wFm.Range("G" & moto).Value
    Else
        wto.Range("J" & saki).Value = wFm.Range("G" & moto).Value
    End If
     
    If saki = 16 Then                                 '残高の記載
        wto.Range("K" & saki).Value = wFm.Range("G" & moto).Value
    Else
        wto.Range("K" & saki).Value = wto.Range("K" & saki - 1).Value + wFm.Range("G" & moto).Value
    End If
End Sub
Sub tenki_kingaku()  'データの転記
 
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
 
    Dim shTo As Worksheet 'ogawa
    Set shTo = Worksheets(Worksheets.Count)
    
    shTo.Range("B" & saki).Value = Format((shFm.Range("C" & moto).Value), "yy")
    shTo.Range("C" & saki).Value = Format(shFm.Range("C" & moto).Value, "m")
    shTo.Range("D" & saki).Value = Format(shFm.Range("C" & moto).Value, "d")
    shTo.Range("E" & saki).Value = shFm.Range("D" & moto).Value
    shTo.Range("F" & saki).Value = shFm.Range("E" & moto).Value
    shTo.Range("H" & saki).Value = shFm.Range("F" & moto).Value
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        shTo.Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        shTo.Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
     
    If saki = 16 Then                                 '残高の記載
        shTo.Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        shTo.Range("K" & saki).Value = shTo.Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
End Sub
 
Sub keisen()  '罫線作成

      With Range("B16:K" & Range("K" & Rows.Count).End(xlUp).Row)
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
      End With
End Sub

Sub header_footer()   '印刷範囲、ヘッダー、フッダーの設定(追加分)
    
    '以下、 with の中は一段インデントすること ogawa
    'なお、正解は、「プログラムでなんとかするのではなく、テンプレートをいじる」でした (^^; ogawa
    With ActiveSheet.PageSetup
    .PrintArea = "A1:L" & Range("K" & Rows.Count).End(xlUp).Row + 1 '印刷範囲の設定
    .CenterHorizontally = True
    .CenterHeader = "&""明朝""&A"                                   'ヘッダーに取引先名称
    .CenterFooter = "&""MS P明朝,標準""&12" & Str(sheet_num)     'フッダーにシート番号
    End With
    
    sheet_num = sheet_num + 1
    
End Sub

Sub num_sort()     'Noで並べ替え
 
    Worksheets("main").Select
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub num_del()     'A列のNoを削除(追加分)

'    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Clear
    Columns(1).Clear 'ogawa
End Sub


9482 : 受講生さんのコメント (2018-02-26 19:27:12)

小川先生

お世話になっております。
(2/25に返信をいただいた受講生です。)

先日指摘頂いた内容を修正した上で、
課題の内容を追加しました。

ヘッダーに関しては、"取引先名称"
フッダーに関しては、"シートNo"
上記のような設定内容としました。

添削の方、よろしくお願いします。

Option Explicit

Dim moto As Long    '転記元行番号
Dim saki As Long    '転記先行番号
Public sheet_num As Long   'フッダー用のシート番号

Sub main()  'メインの実行プロシージャ
    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort
    num_del
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)

    Dim w As Worksheet

    For Each w In Worksheets
        Select Case w.Name
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
     
    Range("A2").Value = "1"    'AutoFillによる番号の割り当て
    Range("A2").AutoFill Destination:=Range("A2:A" & LastNum), Type:=xlFillSeries
End Sub
 
Sub name_sort()     '名称で並べ替え
 
    Worksheets("main").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Sub Create_Voucher() 'シート作成用
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")

    sheet_num = 1
     
    For moto = 2 To LastNum
                                     
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                Call header_footer                                       'ヘッダーフッダーの作成を行う
            End If
            saki = 16                                                    '転送先の行番号を初期化する
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
        End If
         
        Call tenki_kingaku
        saki = saki + 1
    Next
    Call keisen                                                  '最終行書込み後、罫線を引く
    Call header_footer                                           'ヘッダーフッダーの作成を行う
End Sub
  
Sub tenki_kingaku()  'データの転記
 
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
 
    Worksheets(Worksheets.Count).Range("B" & saki).Value = Format((shFm.Range("C" & moto).Value), "yy")
    Worksheets(Worksheets.Count).Range("C" & saki).Value = Format(shFm.Range("C" & moto).Value, "m")
    Worksheets(Worksheets.Count).Range("D" & saki).Value = Format(shFm.Range("C" & moto).Value, "d")
    Worksheets(Worksheets.Count).Range("E" & saki).Value = shFm.Range("D" & moto).Value
    Worksheets(Worksheets.Count).Range("F" & saki).Value = shFm.Range("E" & moto).Value
    Worksheets(Worksheets.Count).Range("H" & saki).Value = shFm.Range("F" & moto).Value
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        Worksheets(Worksheets.Count).Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
     
    If saki = 16 Then                                 '残高の記載
        Worksheets(Worksheets.Count).Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("K" & saki).Value = Worksheets(Worksheets.Count).Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
End Sub
 
Sub keisen()  '罫線作成

      With Range("B16:K" & Range("K" & Rows.Count).End(xlUp).Row)
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
      End With
End Sub

Sub header_footer()   '印刷範囲、ヘッダー、フッダーの設定(追加分)
    
    With ActiveSheet.PageSetup
    .PrintArea = "A1:L" & Range("K" & Rows.Count).End(xlUp).Row + 1 '印刷範囲の設定
    .CenterHorizontally = True
    .CenterHeader = "&""明朝""&A"                                   'ヘッダーに取引先名称
    .CenterFooter = "&""MS P明朝,標準""&12" & Str(sheet_num)     'フッダーにシート番号
    End With
    
    sheet_num = sheet_num + 1
    
End Sub

Sub num_sort()     'Noで並べ替え
 
    Worksheets("main").Select
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub num_del()     'A列のNoを削除(追加分)

    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Clear
End Sub


9328 : 小川慶一の回答 (2018-01-05 17:15:11)

受講生 さん:

'全体によく書けていますね! v(^^*
Sub continue_works()
    Call sheet_delete
    Call print_form_amend
    Call get_number
    Call company_name_sort
    Call made_denpyo
End Sub
Sub sheet_delete()
    Dim ss As Worksheet
    Application.DisplayAlerts = False
    For Each ss In Worksheets
        If Left((ss.Name), 4) <> "main" Then
            ss.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub get_number()
    Dim ctn As Long
    Dim lastrow As Long
    lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
    For ctn = 2 To lastrow
        Worksheets("main").Range("a" & ctn).Value = ctn - 1
     Next
    Worksheets("main").Range("a1").Value = "No."
End Sub
Sub company_name_sort()
    Worksheets("main").Range("A1:G317").Sort _
    Key1:=Range("B2"), _
    Order1:=xlAscending, _
    Header:=xlYes
    Range("B1").Select
End Sub
Sub number_return_delete()
    Dim lastrow As Long
    lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
'    Worksheets("main").Range("A1:G" & lastrow).Sort _
'    Key1:=Range("a1"), _
'    Order1:=xlAscending, _
'    Header:=xlYes
    '↓シート「main」がアクティブでないので、key1の指定がシート名から必要です。よくあるハマりです。そういう意味では、 company_name_sort の並べ替えも、たまたまうまく言っているだけです。
    Worksheets("main").Range("A1:G" & lastrow).Sort _
    Key1:=Worksheets("main").Range("a1"), _
    Order1:=xlAscending, _
    Header:=xlYes
    
    Columns("A:A").Delete
    Columns("a:a").Insert
    Columns("B:B").ColumnWidth = 10
    Columns("a:a").ColumnWidth = 5
End Sub
Private Sub Sort_by_Torihikisaki()
    Range("A1:G317").Sort _
        Key1:=Range("B1"), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub
Private Sub Sort_by_No()
    Range("A1:G317").Sort _
        Key1:=Range("A1"), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub

Sub made_denpyo()
    '↓以下のコメント、秀逸! v(^^*
    '手順1):main1シートをコピーする
    '手順2):新シート名前を取得
    '手順3):新シートのrangeB~RangeKまで内容転記
    '手順4):ForNextを使って全ての取引先名でシート作成
    '手順5):罫線作成
    Dim ctn As Long
    Dim into As Long
    Dim n As String
    Dim ss As Worksheet
    Dim st As Worksheet
    Set st = Worksheets("main")
    Dim lastrow As Long
    lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
    For ctn = 2 To lastrow
    
        '↓If ... End If の間、インデントひとつ少ないです。
    If st.Range("b" & ctn).Value <> st.Range("b" & ctn - 1).Value Then
    '罫線作成タイミングは新規シート作成手前
        If ctn > 2 Then
            Call keisen
        End If
        Sheets("main1").Select
        Sheets("main1").Copy After:=Sheets(Sheets.Count)
        Set ss = ActiveSheet
        n = st.Range("b" & ctn).Value
        ss.Name = n
        into = 16
    End If
        ss.Range("e" & into).Value = st.Range("d" & ctn).Value
        ss.Range("f" & into).Value = st.Range("e" & ctn).Value
        ss.Range("h" & into).Value = st.Range("f" & ctn).Value
        If st.Range("g" & ctn).Value > 0 Then
            ss.Range("i" & into).Value = st.Range("g" & ctn).Value
        Else
            ss.Range("j" & into).Value = st.Range("g" & ctn).Value
        End If
            '↓インデントひとつ余計です。
            ss.Range("b" & into).Value = Right(Year(dt), 2)
            ss.Range("c" & into).Value = Month(dt)
            ss.Range("d" & into).Value = Day(dt)
            into = into + 1
    Next
    Call keisen
    Call number_return_delete
End Sub
Sub keisen()
    Dim lr As Long
    lr = Range("b65536").End(xlUp).Row
    
    'select, selectionがない状態にしたいですね。
    Range("B16:K" & lr + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Sub print_form_amend()
    '以下の with ... endwith は、実は、シート「main1」の書式をいじれば不要でした (^^;
    With ActiveSheet.PageSetup
        .LeftHeader = "&A"
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "&D"
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
    End With
    Application.PrintCommunication = True
    ActiveWindow.View = xlPageLayoutView
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.PageSetup.PrintArea = "$A$1:$M$36"
End Sub


9325 : 受講生さんのコメント (2018-01-04 23:51:48)

小川先生
大変お世話になっております。
添付セミナーNo.11の宿題を送ります。
下記のところでエラーが出ました。
------------------------------------------
Sub number_return_delete()
Dim lastrow As Long
lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
Worksheets("main").Range("A1:G" & lastrow).Sort _
Key1:=Range("a1"), _
Order1:=xlAscending, _
Header:=xlYes
------------------------------
何回も確認をしましたが、エラーの原因究明をうまくできませんでした。
大変お手数ですが、マクロの確認修正をよろしくお願いいたします。
どうぞ、お力を貸していただけますようにお願いします。


9040 : 小川慶一の回答 (2017-10-11 19:02:21)

受講生 さん:

> 印刷範囲をクリアするコード(.PrintArea = "")が必要だと
> わかるまで時間がかかりました(汗)

正解は、「新シートを作る都度処理を行うのではなく、テンプレートのシートをいじる」でした (^^;
受講生さんには、もう、まずはこのくらいで十分かと思いますよ。先に進んでください v(^^*


> 小川先生、いつもお世話になっております。
>
> 【動画9】のフィードバック(コメント:9020)を踏まえ、
> 追加要件も実装しました。
> 印刷範囲をクリアするコード(.PrintArea = "")が必要だと
> わかるまで時間がかかりました(汗)
> 添削の程、よろしくお願い致します。


9029 : 受講生さんのコメント (2017-10-10 13:40:18)

小川先生、いつもお世話になっております。

【動画9】のフィードバック(コメント:9020)を踏まえ、
追加要件も実装しました。
印刷範囲をクリアするコード(.PrintArea = "")が必要だと
わかるまで時間がかかりました(汗)
添削の程、よろしくお願い致します。

Option Explicit
Dim wOg As Worksheet    '原本シート(main)の変数
Dim wDa As Worksheet    'データシート(main1)の変数
Dim cDaMxRow As Long    'データシート(main1)の最終行を示す変数
Dim cMkRow As Long      '新規シートの行を指定する変数
Dim Skey As String      'データシートの並び替えを指定する変数
    
Public Sub Homework()
    Set wOg = Worksheets("main1")
    Set wDa = Worksheets("main")
    cDaMxRow = wDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DelDenpyou
    BangouFuri
    
    Skey = "B1"
    Narabikae

    CreateDenpyou

    Skey = "A1"
    Narabikae

    DeleteBangou
End Sub

Public Sub DelDenpyou()
    Dim Wsh As Worksheet
    Application.DisplayAlerts = False
    For Each Wsh In Worksheets
        With Wsh
            If .Name <> "main" And .Name <> "main1" Then  '←if文に変更
                .delete
            End If
        End With
    Next Wsh
    Application.DisplayAlerts = True
    PrintSet '[★]追加要件
End Sub

Sub PrintSet() '[★]追加要件
    If wOg.Name = "main" Then
        With wOg.PageSetup
            .LeftHeader = "&A"
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = "[作成日]&D"
        End With
    Else
        With ActiveSheet.PageSetup
            .PrintArea = ""
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
    End If
End Sub

Public Sub BangouFuri()
    Dim cNt As Long
    With wDa.Range("A1")
        .Offset(0, 0).Value = "No."
        For cNt = 1 To 3
            .Offset(cNt, 0).Value = cNt
        Next cNt
    End With
    wDa.Range("A2:A4").AutoFill Destination:=wDa.Range("A2:A" & cDaMxRow)
End Sub

Public Sub CreateDenpyou()
    Dim wMk As Worksheet
    Dim cDaRow As Long
    Dim sClnt As String
    Dim dTda As Date
    For cDaRow = 2 To cDaMxRow
        If sClnt <> wDa.Range("B" & cDaRow).Value Then
            If cDaRow > 2 Then
                Keisen
                PrintSet '[★]追加要件
            End If
            wOg.Copy after:=Worksheets(Worksheets.Count)
            sClnt = wDa.Range("B" & cDaRow).Value
            Set wMk = ActiveSheet
            wMk.Name = sClnt
            cMkRow = 16
        End If
        dTda = wDa.Range("C" & cMkRow).Value
        With wMk
            .Range("B" & cMkRow).Value = Mid(Year(dTda), 3)
            .Range("C" & cMkRow).Value = Month(dTda)
            .Range("D" & cMkRow).Value = Day(dTda)
            .Range("E" & cMkRow).Value = wDa.Range("D" & cMkRow).Value
            .Range("F" & cMkRow).Value = wDa.Range("E" & cMkRow).Value
            .Range("H" & cMkRow).Value = wDa.Range("F" & cMkRow).Value
            If wDa.Range("G" & cMkRow).Value > 0 Then
                .Range("I" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            Else
                .Range("J" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            End If
            .Range("K" & cMkRow).Value = WorksheetFunction.Sum(.Range("I16:J" & cMkRow))
        End With
        cMkRow = cMkRow + 1
    Next cDaRow
    Keisen
End Sub

Public Sub Keisen()
    With Range("B16:K" & cMkRow)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Public Sub Narabikae()
    With wDa
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=wDa.Range(Skey), Order:=xlAscending
            End With
            .SetRange wDa.Range("A1:G" & cDaMxRow)
            .Header = xlYes
            .Apply
        End With
    End With
End Sub

Public Sub DeleteBangou()
    With wDa
        .Activate '←ここに記載し、1回のみの処理に変更
        .Range("A1").Activate
        .Range("A1").EntireColumn.ClearContents
    End With
End Sub


7545 : 小川慶一の回答 (2017-01-22 09:49:30)

受講生 さん:

全体に、とてもよく書けていると思います。すばらしいです。
コメント参照して、もう少し研究してみてください。

>印刷範囲とヘッダーを追加した伝票作成マクロの作成を致しました。

正解は、「新シートを作る都度処理を行うのではなく、テンプレートのシートをいじる」でした。

Option Explicit
Dim Mn As Worksheet
Dim Mn1 As Worksheet
Dim Amax As Long
 
Sub Denpyo_making()
    Set Mn = Worksheets("main")
    Set Mn1 = Worksheets("main1")
    Amax = Mn.Range("B65536").End(xlUp).Row
    
    Deletesheets1
    Numbering
    Narabikae
    sheets_making
    Narabikae2
    syuseiH_C
End Sub
'プロシージャ名最後に1がつくのはなぜ?
Sub Deletesheets1()
    Dim Ws As Worksheet
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If Left(Ws.Name, 4) <> "main" Then
            Ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
'シンプルでよいですね。
'このくらい短いと、 Denpyo_making に含めてもいいかも。
Sub Numbering()
    Mn.Range("A2").Value = 1
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
End Sub
Sub Narabikae()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("B1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A1:G" & Amax)
        .Header = xlYes
        .Apply
    End With
End Sub
Sub sheets_making()
    Dim Namae As String
    Dim gyo As Long
    Dim Nws As Worksheet
    Dim dt As Date '日付
    Dim saki As Long
    
    For gyo = 2 To Amax
        If Namae <> Mn.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen_making '最初だけ罫線回避
            End If
            Namae = Mn.Range("B" & gyo).Value
            Sheets("main1").Copy After:=Sheets(Sheets.Count)
            Sheets("main1 (2)").Select
            Sheets("main1 (2)").Name = Namae
            Set Nws = Worksheets(Namae)
            saki = 16
        End If
        dt = Mn.Range("C" & gyo).Value
        '↓以下の3つ、format関数を使った表現も研究してください。
        Nws.Range("B" & saki).Value = Right(Year(dt), 2)
        Nws.Range("C" & saki).Value = Month(dt)
        Nws.Range("D" & saki).Value = Day(dt)
        Nws.Range("F2").Value = Mn.Range("B" & gyo).Value
        Nws.Range("E" & saki).Value = Mn.Range("D" & gyo).Value
        Nws.Range("F" & saki).Value = Mn.Range("E" & gyo).Value
        Nws.Range("H" & saki).Value = Mn.Range("F" & gyo).Value
        
        If Mn.Range("G" & gyo).Value > 0 Then
            Nws.Range("I" & saki).Value = Mn.Range("G" & gyo).Value
        Else
            Nws.Range("J" & saki).Value = Mn.Range("G" & gyo).Value
        End If
        Nws.Range("K" & saki).Value = Nws.Range("I" & saki).Value + Nws.Range("J" & saki).Value
        saki = saki + 1
    Next
    keisen_making '最後の会社のシートに罫線つける
End Sub
 Sub keisen_making()
    Dim cNewmax
    cNewmax = Range("B65536").End(xlUp).Row
    'select, selectionを以下から除けますか。本編の自動記録について解説しているところで復習を!
    Range("B16:K" & cNewmax).Select
'    Range("B16:K" & Range("B65536").End(xlUp).Row).Select'←この書き方なら、変数宣言も不要になりますね。
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Sub Narabikae2()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("C1"), Order:=xlAscending
    With Mn.Sort
        '↓これだと、並べ替え対象は3行目以降になってしまいますが。。動作確認OKでしょうか?
        .SetRange Range("A2:G" & Amax)
        .Header = xlYes
        .Apply
    End With
    '↓以下もよいかも。
    Range("A2:A" & Amax).ClearContents
    Mn.Range("A2").Value = ""
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
    
End Sub
'↓テンプレのほうをあらかじめいじっておけばこのプロセスまるまる不要
Sub syuseiH_C()
    Dim cNewmax As Long
    Dim c As Long
    Dim Wh As Worksheet
    cNewmax = Range("B65536").End(xlUp).Row
    
    For Each Wh In Worksheets
        If Left(Wh.Name, 4) <> "main" Then
            With Wh.PageSetup
                .LeftHeader = Wh.Name
                .RightHeader = "&D"
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
            End With
            ActiveSheet.PageSetup.PrintArea = "A1:K" & cNewmax
        End If
    Next
End Sub


7542 : 受講生さんのコメント (2017-01-21 23:29:13)

小川先生、いつもお世話になっております。
印刷範囲とヘッダーを追加した伝票作成マクロの作成を致しました。

モジュールレベルの変数とプロシージャレベルの変数をうまく使い分けることがまだ難しいように感じました。
添削の程、何卒よろしくお願いします。

Option Explicit
Dim Mn As Worksheet
Dim Mn1 As Worksheet
Dim Amax As Long
 
Sub Denpyo_making()
    Set Mn = Worksheets("main")
    Set Mn1 = Worksheets("main1")
    Amax = Mn.Range("B65536").End(xlUp).Row
    
    Deletesheets1
    Numbering
    Narabikae
    sheets_making
    Narabikae2
    syuseiH_C

End Sub

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

Sub Numbering()

    Mn.Range("A2").Value = 1
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries

End Sub

Sub Narabikae()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("B1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A1:G" & Amax)
        .Header = xlYes
        .Apply
    End With
End Sub

Sub sheets_making()
    Dim Namae As String
    Dim gyo As Long
    Dim Nws As Worksheet
    Dim dt As Date '日付
    Dim saki As Long
    
    For gyo = 2 To Amax
        If Namae <> Mn.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen_making '最初だけ罫線回避
            End If
            Namae = Mn.Range("B" & gyo).Value
            Sheets("main1").Copy After:=Sheets(Sheets.Count)
            Sheets("main1 (2)").Select
            Sheets("main1 (2)").Name = Namae
            Set Nws = Worksheets(Namae)
            saki = 16
        End If

        dt = Mn.Range("C" & gyo).Value
        Nws.Range("B" & saki).Value = Right(Year(dt), 2)
        Nws.Range("C" & saki).Value = Month(dt)
        Nws.Range("D" & saki).Value = Day(dt)
        Nws.Range("F2").Value = Mn.Range("B" & gyo).Value
        Nws.Range("E" & saki).Value = Mn.Range("D" & gyo).Value
        Nws.Range("F" & saki).Value = Mn.Range("E" & gyo).Value
        Nws.Range("H" & saki).Value = Mn.Range("F" & gyo).Value
        
        If Mn.Range("G" & gyo).Value > 0 Then
            Nws.Range("I" & saki).Value = Mn.Range("G" & gyo).Value
        Else
            Nws.Range("J" & saki).Value = Mn.Range("G" & gyo).Value
        End If
        Nws.Range("K" & saki).Value = Nws.Range("I" & saki).Value + Nws.Range("J" & saki).Value
        saki = saki + 1
    Next
    keisen_making '最後の会社のシートに罫線つける
End Sub

 Sub keisen_making()
    Dim cNewmax
    cNewmax = Range("B65536").End(xlUp).Row
    Range("B16:K" & cNewmax).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Sub Narabikae2()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("C1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A2:G" & Amax)
        .Header = xlYes
        .Apply
    End With
    Mn.Range("A2").Value = ""
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
    
End Sub
    
Sub syuseiH_C()
    Dim cNewmax As Long
    Dim c As Long
    Dim Wh As Worksheet
    cNewmax = Range("B65536").End(xlUp).Row
    
    For Each Wh In Worksheets
        If Left(Wh.Name, 4) <> "main" Then
            With Wh.PageSetup
                .LeftHeader = Wh.Name
                .RightHeader = "&D"
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
            End With
            ActiveSheet.PageSetup.PrintArea = "A1:K" & cNewmax
        End If
    Next
End Sub


7324 : 小川慶一の回答 (2016-11-22 19:03:35)

受講生 さん:

この演習は、以下の動画解説どおりにひとつづつ自力で問題を解けるようになるまでくり返すのがいちばん力つきますよ。
https://online.pc5bai.com/movie/index/26

>また変数名を何にするか決めるのに時間がかかり決めた変数名に自信が持てません。

「ハンガリアン記法」で行きましょう。
第1章の復習お願いします。

以下、まだ直そうと思えば直せるところもありますが、まずは添削です。

'全体に、コメントのタイミングと内容、適切と感じます。 v(^^ ogawa
'一方、細かいところでもう一歩踏み込みたいものもあります。
Sub denpyoMake()
'mainシートの取引先名称ごとにシートを分ける

    Dim shFm As Worksheet
    Dim shTo As Worksheet
    Dim sortMaeNum As Long
    Dim sortMaeNumMx 'データ型抜けてます ogawa
    Dim lnfm As Long
    Dim lnfmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    
    'main、main1以外のシートを削除
    deleteSheet
    
    '↓autofilterで番号を入れる方法も調査してみてください ogawa
    sortMaeNumMx = Range("B" & Rows.Count).End(xlUp).Row
    For sortMaeNum = 2 To sortMaeNumMx
        shFm.Range("A" & sortMaeNum).Value = sortMaeNum - 1
    Next sortMaeNum
    
    'mainシートでソートする
    sortTorihiki '変数名も sort という小文字ではじまりますね。。「ハンガリアン記法」について復習を!
    
    lnfmMx = Range("B" & Rows.Count).End(xlUp).Row
    For lnfm = 2 To lnfmMx
        If shFm.Range("B" & lnfm).Value <> shFm.Range("B" & lnfm - 1).Value Then
            If lnfm <> 2 Then
                '罫線を引く
                keisenDraw (lnTo)
            
                '印刷範囲を設定する
                printSetting (lnTo)
            End If
            
            Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shFm.Range("B" & lnfm).Value
            Set shTo = ActiveSheet
            shTo.Range("F2").Value = shTo.Name
            lnTo = 16
        Else
            lnTo = lnTo + 1
        End If
        dt = shFm.Range("C" & lnfm).Value
        '↓format関数の活用も研究してください。ogawa
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnfm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnfm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnfm).Value
        If shFm.Range("G" & lnfm).Value > 0 Then
            shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnfm).Value
        Else
            shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnfm).Value
        End If
        shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + shFm.Range("G" & lnfm).Value
            
    Next lnfm
    
    'mainシートを元の順番でソートする
    sortMotojun
    '↑最後のシートだけ、ヘッダーとフッターの記載が抜けています。 ogawa
    shFm.Activate
    shFm.Range("A1").Select
    
End Sub

Private Sub sortTorihiki()
'取引先名称で並び替える
    '以下だいたいよいですが、僕なら先にNoという文字列をセルA1に入れるかな。それまでは、並べ替えする表の見出しがない状態なわけですから。 ogawa
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No"
End Sub

Private Sub sortMotojun()
'元の並び順に並び替える
    '↓どのシートの?そこを指定しないと Activesheet で選択されてしまいます。
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '↓どのシートの?そこを指定しないと Activesheet で実行されてしまいます。(2016以降ではなぜかこれでも結果的に目論見どおりに動くが)
    Range("A:A").ClearContents
End Sub

Private Sub deleteSheet()
' main、main1以外のシートを削除する

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

Private Sub keisenDraw(mxGyo As Long)
'追加シートに罫線を引く

    With Range("B16:K" & mxGyo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub printSetting(maxGyo As Long)
'印刷範囲を変更する。またヘッダ・フッタを入れる。
'↓インデント不正。そもそも .select の行は不要です。
Range("A1:L" & maxGyo).Select
    '以下、不必要なものは削ってください。
    ActiveSheet.PageSetup.PrintArea = "A1:L" & maxGyo + 1
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&A"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .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 = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 10
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub


7323 : 受講生さんのコメント (2016-11-22 18:18:32)

小川先生
お世話になっております。
10月末から勉強させていただいております。
複数シート間で処理をするときのプログラムの書き方がまだしっかりと身についていません。
また変数名を何にするか決めるのに時間がかかり決めた変数名に自信が持てません。
引き続き身につくよう勉強していきます。
読みにくいコードとなり申し訳ありませんがご確認お願いいたします。

Sub denpyoMake()
'mainシートの取引先名称ごとにシートを分ける

    Dim shFm As Worksheet
    Dim shTo As Worksheet
    Dim sortMaeNum As Long
    Dim sortMaeNumMx
    Dim lnfm As Long
    Dim lnfmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    
    'main、main1以外のシートを削除
    deleteSheet
    
    sortMaeNumMx = Range("B" & Rows.Count).End(xlUp).Row
    For sortMaeNum = 2 To sortMaeNumMx
        shFm.Range("A" & sortMaeNum).Value = sortMaeNum - 1
    Next sortMaeNum
    
    'mainシートでソートする
    sortTorihiki
    
    lnfmMx = Range("B" & Rows.Count).End(xlUp).Row
    For lnfm = 2 To lnfmMx
        If shFm.Range("B" & lnfm).Value <> shFm.Range("B" & lnfm - 1).Value Then
            If lnfm <> 2 Then
                '罫線を引く
                keisenDraw (lnTo)
            
                '印刷範囲を設定する
                printSetting (lnTo)
            End If
            
            Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shFm.Range("B" & lnfm).Value
            Set shTo = ActiveSheet
            shTo.Range("F2").Value = shTo.Name
            lnTo = 16
        Else
            lnTo = lnTo + 1
        End If
        dt = shFm.Range("C" & lnfm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnfm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnfm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnfm).Value
        If shFm.Range("G" & lnfm).Value > 0 Then
            shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnfm).Value
        Else
            shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnfm).Value
        End If
        shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + shFm.Range("G" & lnfm).Value
            
    Next lnfm
    
    'mainシートを元の順番でソートする
    sortMotojun

    shFm.Activate
    shFm.Range("A1").Select
    
End Sub

Private Sub sortTorihiki()
'取引先名称で並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No"
End Sub

Private Sub sortMotojun()
'元の並び順に並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A:A").ClearContents
End Sub

Private Sub deleteSheet()
' main、main1以外のシートを削除する

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

Private Sub keisenDraw(mxGyo As Long)
'追加シートに罫線を引く

    With Range("B16:K" & mxGyo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub printSetting(maxGyo As Long)
'印刷範囲を変更する。またヘッダ・フッタを入れる。

Range("A1:L" & maxGyo).Select
    ActiveSheet.PageSetup.PrintArea = "A1:L" & maxGyo + 1
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&A"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .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 = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 10
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub


5663 : 小川慶一の回答 (2016-01-25 00:20:14)

受講生 さん:

> ループの初回の罫線設定回避策もよく理解出来て、スラスラと書けるようになりました。

よかったです。
なにしろ、ここは、ある意味難所なので。
でも、一度自力でやったからこそ、解説がよく理解できますね。

いただいたマクロ。
いいですね。ほぼほぼカンペキです。

とりわけ、変数 wTmp とかシブいです。

ここまでできれば相当の仕事でもできるはずです ヾ(´ー`)ノ

autofillの準備に2つのデータを投入している箇所は、 .Value でもOKです。
データ数が316件を超えたときに一部不具合が出るので、そこを修正してみてください。

>小川先生、いつもお世話になっております。
>追加要件の宿題を提出いたします。前回の宿題提出時に頂いたご指導のお陰で、ループの初回の罫線設定回避策もよく理解出来て、スラスラと書けるようになりました。
>今回はオートフィルでA列に番号を振る別解としました。オートフィルのハンドル部分をダブルクリックするだけで、表がある部分全てにオートフィルが実行されることは知らなかったので、
>また新たな学びが出来ました。(今更というカンジですが…(;・∀・))添削ご指導よろしくお願いいたします。


5661 : 受講生さんのコメント (2016-01-24 15:06:17)

小川先生、いつもお世話になっております。
追加要件の宿題を提出いたします。前回の宿題提出時に頂いたご指導のお陰で、ループの初回の罫線設定回避策もよく理解出来て、スラスラと書けるようになりました。
今回はオートフィルでA列に番号を振る別解としました。オートフィルのハンドル部分をダブルクリックするだけで、表がある部分全てにオートフィルが実行されることは知らなかったので、
また新たな学びが出来ました。(今更というカンジですが…(;・∀・))添削ご指導よろしくお願いいたします。

Sub creatDenpyo()
    deleteDenpyo
    
    Dim wFm As Worksheet
    Set wFm = Worksheets("main")
    Dim wTmp As Worksheet
    Set wTmp = Worksheets("main1")
    Dim wTo As Worksheet
    
    '(1)A列に番号を振る(オートフィルで)
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A3").FormulaR1C1 = "2"
    wFm.Range("A2:A3").AutoFill Destination:=wFm.Range("A2:A317")

    '(2)B列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes

    '(3)伝票テンプレートにヘッダー/フッター挿入、印刷範囲設定クリア
    With wTmp.PageSetup
        .CenterHeader = "&A"
        .CenterFooter = "&P / &N ページ"
        .PrintArea = ""
    End With
    
    '(4)伝票作成
    Dim gyo As Long
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim gyoTo As Long
    gyoTo = 16
    For gyo = 2 To gyoMax
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If gyo > 2 Then
                keisen
            End If
            gyoTo = 16
            wTmp.Copy After:=Sheets(2)
            Set wTo = ActiveSheet
            wTo.Name = wFm.Range("B" & gyo).Value
        End If
        wTo.Range("B" & gyoTo) = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo) = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo) = Day(wFm.Range("C" & gyo).Value)
        wTo.Range("E" & gyoTo) = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo) = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo) = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo) = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo) = wFm.Range("G" & gyo).Value
        End If
        If gyoTo > 16 Then
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value + wTo.Range("K" & gyoTo - 1).Value
        Else
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
    keisen

    '(5)A列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("A1"), Order1:=xlAscending, Header:=xlYes

    '(6)A列の値消去
    wFm.Range("A1:A317").ClearContents
End Sub

Sub deleteDenpyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main1" And ws.Name <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub keisen()
    Dim gyoMax
    gyoMax = Range("B" & Rows.Count).End(xlUp).Row
    
    With Range("B16", "K" & gyoMax)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub


2787 : 小川慶一の回答 (2014-10-23 12:46:31)

匿名 さん:

でプログラムをくくってください。
そうすると、プログラムのソースそのままのレイアウトで投稿できます。
(と書いて、以前はそういう案内を投稿欄に書いていたのに、消えていたのに気がついた。。)

ひきつづきよろしくお願いいたします。

>分からない部分はマクロ記録で調べながら、宿題を完成させ提出しました。
>インデントを設定してここに貼り付けても、「送信」した時点でインデントが消えてしまいます。


2781 : 受講生さんのコメント (2014-10-22 23:25:52)

分からない部分はマクロ記録で調べながら、宿題を完成させ提出しました。
インデントを設定してここに貼り付けても、「送信」した時点でインデントが消えてしまいます。


3295 : ガラパゴスタディー事務局の回答 (2014-07-14 07:54:00)

木谷さん:

達人養成塾 小川です。

[1]罫線を引くタイミングについて

[a]
データを一行追記する都度罫線を引いていると冗長。
できれば、各シート1回ですませたい。

[b]
[a]を満たすためには、「次のシートでの処理」を開始する直前に罫線を引けばよい。

[c]
ただし、[b]をそのままやると、以下の問題が生じる。
[c-1]元データのあるシートでも罫線が引かれてしまう。
[c-2]最後のシートは罫線が引かれない。

[d]
[c-1], [c-2]の問題を解消するため、以下のとおりにする。
[d-1] 「最初のシートでの処理」を開始する前は罫線は引かない
[d-2] 「最後のシートでの処理」を終えた直後にも罫線を引く


[2]伝票用テンプレートの印刷範囲の設定について

OKです。
それでやってみてください!


3294 : 木谷 太一さんのコメント (2014-07-12 09:32:00)

添削いただきありがとうございます。
ヒントにもとにもう一度コードを修正しながら考えてみました。
ご指摘の2点については、このように理解すればよろしいでしょうか。
[1]罫線を引くタイミングについて
  ①ループ内の if 文の中のみだと、最後にコピーしたシート(宮崎繊維)に罫線が引かれない。
   さらに、「main」シートの2行目の処理と、3行目以降の処理を振り分ける必要がある。
   振り分けをしないと「main1」シートをコピーする前に「main」シート内に罫線を引こうとして
   エラーとなる。    
  ②ループの外の1回のみだと、今度は最後にコピーしたシート(宮崎繊維)にのみ罫線が引かれてしまう。
  ①②より、罫線を引く処理は「ループ内の if 文の中」と、「ループの外」に1つづつ、
  2回処理を行う必要がある。
[2]伝票用テンプレートの印刷範囲の設定について
  プログラミングの問題ではないのでは?あらかじめ伝票用テンプレートの印刷範囲を広げておけば済む
  ことではないかと思いました。
以上です。長文失礼しました。


3293 : ガラパゴスタディー事務局の回答 (2014-07-12 03:28:00)

木谷さん:

以下にて指摘した2カ所のコードについて、置き場所を再検討してください。
(先にいただいた no.9 の課題でも、 keisen の場所は要再検討でした。気づきませんでした。すいません。)

ヒントは、「ループ内の if 文の中」と、「ループの外」に1つづつ、です。

Option Explicit
 
Dim ws As Worksheet
Dim wsFm As Worksheet
Dim wsTo As Worksheet
Dim Retsu As String
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim dt As Date
Public Sub Dempyo_Sakusei()
    Application.ScreenUpdating = False
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
     
    Delete_Dempyo
     
    No_Furi
     
    Retsu = "B"
    Sort_main
     
    Genko_Sakusei
 
    wsFm.Activate
    Retsu = "A"
    Sort_main
     
    wsFm.Columns("A:A").ClearContents  '追加要件②です
     
    Application.ScreenUpdating = True
    MsgBox "伝票作成終了しました"
End Sub
Public Sub Delete_Dempyo()
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main" And ws.Name <> "main1" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub Genko_Sakusei()
     
    For lnFm = 2 To lnFmMx
        If wsFm.Range("B" & lnFm - 1).Value <> wsFm.Range("B" & lnFm).Value Then
            Worksheets("main1").Copy After:=wsFm
            Set wsTo = ActiveSheet
            wsTo.Name = wsFm.Range("B" & lnFm).Value
     
            '↓ここから追加要件①の1です A4縦印刷に設定しました
            With wsTo.PageSetup
                .CenterHeader = wsTo.Name  'ヘッダーにシート名を入れてみました
                .CenterFooter = Date       'フッターには作成日を入れてみました
                .CenterHorizontally = True
                .Orientation = xlPortrait
                .PaperSize = xlPaperA4
            End With
            '↑ここまでが追加要件①の1です
             
            lnTo = 16
        End If
    Keisen '←場所再検討。 ogawa
    dt = wsFm.Range("C" & lnFm).Value
    wsTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
    wsTo.Range("C" & lnTo).Value = Month(dt)
    wsTo.Range("D" & lnTo).Value = Day(dt)
     
    wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
    wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
    wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
     
    If wsFm.Range("G" & lnFm).Value < 0 Then
        wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    Else
        wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    End If
     
    If lnFm = 16 Then
        wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    Else
        wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo - 1).Value
    End If
    wsTo.PageSetup.PrintArea = "$B$1:$K$" & lnTo   '追加要件①の2です'←場所再検討。 ogawa
    lnTo = lnTo + 1
    Next
End Sub
Private Sub Keisen()
 
        With wsTo.Range("B16:K" & lnTo + 1)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlHairline
            End With
        End With
End Sub
Private Sub No_Furi()
    '「main」シートのA列に通し番号を振る
    For lnFm = 1 To lnFmMx
        With wsFm.Range("A" & lnFm)
            If lnFm = 1 Then
                .Value = "No."
            Else
                .Value = lnFm - 1
            End If
        End With
    Next
End Sub
Private Sub Sort_main()
    '「main」シートのデータを"retsu"列の昇順でソート
    wsFm.Range("A1:G" & lnFmMx).Sort _
        Key1:=Range(Retsu & 1), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub


3292 : 木谷 太一さんのコメント (2014-07-10 10:52:00)

No.9 に引き続き、伝票作成マクロを作ってみましたので、ご覧ください。

題意を勘違いしたかもしれません。今回提出したプログラムでは、「main1」シートの設定はそのままで、新たに作成されたシートの設定のみが変わるようになっています。

 
Option Explicit

Dim ws As Worksheet
Dim wsFm As Worksheet
Dim wsTo As Worksheet
Dim Retsu As String
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim dt As Date
Public Sub Dempyo_Sakusei()
    Application.ScreenUpdating = False
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    
    Delete_Dempyo
    
    No_Furi
    
    Retsu = "B"
    Sort_main
    
    Genko_Sakusei

    wsFm.Activate
    Retsu = "A"
    Sort_main
    
    wsFm.Columns("A:A").ClearContents  '追加要件②です
    
    Application.ScreenUpdating = True
    MsgBox "伝票作成終了しました"
End Sub
Public Sub Delete_Dempyo()
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main" And ws.Name <> "main1" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub Genko_Sakusei()
    
    For lnFm = 2 To lnFmMx
        If wsFm.Range("B" & lnFm - 1).Value <> wsFm.Range("B" & lnFm).Value Then
            Worksheets("main1").Copy After:=wsFm
            Set wsTo = ActiveSheet
            wsTo.Name = wsFm.Range("B" & lnFm).Value
    
            '↓ここから追加要件①の1です A4縦印刷に設定しました
            With wsTo.PageSetup
                .CenterHeader = wsTo.Name  'ヘッダーにシート名を入れてみました
                .CenterFooter = Date       'フッターには作成日を入れてみました
                .CenterHorizontally = True
                .Orientation = xlPortrait
                .PaperSize = xlPaperA4
            End With
            '↑ここまでが追加要件①の1です
            
            lnTo = 16
        End If
    Keisen
    dt = wsFm.Range("C" & lnFm).Value
    wsTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
    wsTo.Range("C" & lnTo).Value = Month(dt)
    wsTo.Range("D" & lnTo).Value = Day(dt)
    
    wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
    wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
    wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
    
    If wsFm.Range("G" & lnFm).Value < 0 Then
        wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    Else
        wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    End If
    
    If lnFm = 16 Then
        wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
    Else
        wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo - 1).Value
    End If
    wsTo.PageSetup.PrintArea = "$B$1:$K$" & lnTo   '追加要件①の2です
    lnTo = lnTo + 1
    Next
End Sub
Private Sub Keisen()

        With wsTo.Range("B16:K" & lnTo + 1)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlHairline
            End With
        End With
End Sub
Private Sub No_Furi()
    '「main」シートのA列に通し番号を振る
    For lnFm = 1 To lnFmMx
        With wsFm.Range("A" & lnFm)
            If lnFm = 1 Then
                .Value = "No."
            Else
                .Value = lnFm - 1
            End If
        End With
    Next
End Sub
Private Sub Sort_main()
    '「main」シートのデータを"retsu"列の昇順でソート
    wsFm.Range("A1:G" & lnFmMx).Sort _
        Key1:=Range(Retsu & 1), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub


3235 : ガラパゴスタディー事務局の回答 (2013-08-08 13:37:00)

望月さん:

いやいやー。フツーに考えたらすごいですよ。
果たして、僕がIBMで社内講師しはじめたころ、
これだけのクオリティのものを書けたかどうか。

> プログラムを作っていると、セミナーの際、先生が強調されていたポイントをよく思い出します
> 指差し確認の事などです

復習しているなかで思い当たることも、いろいろ出てきますね。

ひきつづき、お楽しみを。


3233 : 望月 晋一さんのコメント (2013-08-07 20:49:00)

小川先生、No9の課題に続き、添削いただきまして、ありがとうございました。ご指摘いただいた箇所をじっくり見直して、また一から作ってみます。やはり、自分の考え方、捕え方に足りない点があることを痛感します。プログラムを作っていると、セミナーの際、先生が強調されていたポイントをよく思い出します。指差し確認の事などです。当初はピンと来なかった事も、振り返る中で、意義に気が付くことがあります。手を休めないこと、体を動かすこと、そうした基本が大切だということを再認識しております。


3231 : ガラパゴスタディー事務局の回答 (2013-08-06 10:45:00)

望月さんのコードは、プロシージャ名ほかいろいろ秀逸ですね。
no.9で触れなかったことを中心に、コメント入れます。参考にしてください。

Option Explicit
    Dim nGyo As Long
    Dim nEgyo As Long
    Dim stTn As String
    Dim wsM As Worksheet
    Dim wsD As Worksheet
    Dim nDkisai As Long
    Dim dtMh As Date
    Dim stSk As String
Public Sub DenpyoSakusei()
    DelSheets
    NumFuri
    stSk = "B1"
    MainSort
    CreDenpyo
    stSk = "A1"
    MainSort
    NumShokyo
End Sub
Public Sub DelSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Not (ws.Name Like "main*") Then '←取引先に「main鉱業」とかあるかもしれないので、いちおう注意。
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Private Sub NumFuri()
    Set wsM = Worksheets("main")
    nEgyo = wsM.Range("B" & Rows.Count).End(xlUp).Row '←これ、ほかのプロシージャでも使い回すつもりの変数なんで、値を設定するなら sub denpyosakuesi の中のほうがよい気も。
    For nGyo = 2 To nEgyo
        wsM.Range("A" & nGyo).Value = nGyo - 1
    Next
End Sub
Private Sub MainSort()
    wsM.Range("A1:K" & nEgyo).Sort Key1:=wsM.Range(stSk), order1:=xlAscending, Header:=xlYes
End Sub
Private Sub CreDenpyo()
    For nGyo = 2 To nEgyo
        If stTn <> wsM.Range("B" & nGyo) Then
            If nGyo > 2 Then
                Keisen
                PageSettei '←正解は、「プログラムで解決するのではなく、 main1 の書式を変更する」でした (^^;
            End If
            Worksheets("main1").Copy after:=Worksheets(2)
            Set wsD = ActiveSheet
            stTn = wsM.Range("B" & nGyo).Value
            wsD.Name = stTn
            wsD.Range("J12").Value = stTn
            nDkisai = 16
        End If
        wsD.Range("E" & nDkisai).Value = wsM.Range("D" & nGyo).Value
        wsD.Range("F" & nDkisai).Value = wsM.Range("E" & nGyo).Value
        wsD.Range("H" & nDkisai).Value = wsM.Range("F" & nGyo).Value
        dtMh = wsM.Range("C" & nGyo).Value
        wsD.Range("B" & nDkisai).Value = Format(dtMh, "yy")
        wsD.Range("C" & nDkisai).Value = Format(dtMh, "mm")
        wsD.Range("D" & nDkisai).Value = Format(dtMh, "dd")
        If wsM.Range("G" & nGyo).Value > 0 Then
            wsD.Range("I" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        Else
            wsD.Range("J" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        End If
        If nDkisai = 16 Then
            wsD.Range("K" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        Else
            wsD.Range("K" & nDkisai).Value = wsD.Range("K" & nDkisai - 1).Value _
                                    + wsD.Range("I" & nDkisai).Value _
                                    + wsD.Range("J" & nDkisai).Value
        End If
        nDkisai = nDkisai + 1
    Next
    Keisen
    PageSettei
End Sub
Private Sub Keisen()
    'no.9 で説明したことを参考に書き直してみてください。あと、 selection という言葉は登場しないようにしたい。
    
    '[*1] [*2]までは不要。
    Range("B16:K19").Select
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    '[*2]
    wsD.Range("B16:K" & nDkisai).Select '←nDkisai - 1 だと余白なしにできます。もう少しチャレンジしてみます?
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
End Sub
Private Sub PageSettei()
    wsD.PageSetup.PrintArea = "$B$1:$K$" & nDkisai
End Sub
Private Sub NumShokyo()
    wsM.Activate
    Columns("A:A").ClearContents
    Range("A1").Activate
End Sub


3229 : 望月 晋一さんのコメント (2013-08-05 18:16:00)

伝票作成のプログラムを作りました。よろしければ、見ていただければと思います。前回提出の時は、明細行が2行以下の場合を見落とし、余計な罫線行が残った表を作ってしまいましたが、そうした点を修正しました。よろしくお願いします。

Option Explicit
    Dim nGyo As Long
    Dim nEgyo As Long
    Dim stTn As String
    Dim wsM As Worksheet
    Dim wsD As Worksheet
    Dim nDkisai As Long
    Dim dtMh As Date
    Dim stSk As String

Public Sub DenpyoSakusei()

    DelSheets
    NumFuri
    
    stSk = "B1"
    MainSort
    
    CreDenpyo
    
    stSk = "A1"
    MainSort
            
    NumShokyo

End Sub

Public Sub DelSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Not (ws.Name Like "main*") Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub NumFuri()
    Set wsM = Worksheets("main")
    nEgyo = wsM.Range("B" & Rows.Count).End(xlUp).Row
    For nGyo = 2 To nEgyo
        wsM.Range("A" & nGyo).Value = nGyo - 1
    Next
End Sub

Private Sub MainSort()
    wsM.Range("A1:K" & nEgyo).Sort Key1:=wsM.Range(stSk), order1:=xlAscending, Header:=xlYes

End Sub

Private Sub CreDenpyo()
    For nGyo = 2 To nEgyo
        If stTn <> wsM.Range("B" & nGyo) Then
            If nGyo > 2 Then
                Keisen
                PageSettei
            End If
            Worksheets("main1").Copy after:=Worksheets(2)
            Set wsD = ActiveSheet
            stTn = wsM.Range("B" & nGyo).Value
            wsD.Name = stTn
            wsD.Range("J12").Value = stTn
            nDkisai = 16
        End If
        wsD.Range("E" & nDkisai).Value = wsM.Range("D" & nGyo).Value
        wsD.Range("F" & nDkisai).Value = wsM.Range("E" & nGyo).Value
        wsD.Range("H" & nDkisai).Value = wsM.Range("F" & nGyo).Value
        dtMh = wsM.Range("C" & nGyo).Value
        wsD.Range("B" & nDkisai).Value = Format(dtMh, "yy")
        wsD.Range("C" & nDkisai).Value = Format(dtMh, "mm")
        wsD.Range("D" & nDkisai).Value = Format(dtMh, "dd")
        If wsM.Range("G" & nGyo).Value > 0 Then
            wsD.Range("I" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        Else
            wsD.Range("J" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        End If
        If nDkisai = 16 Then
            wsD.Range("K" & nDkisai).Value = wsM.Range("G" & nGyo).Value
        Else
            wsD.Range("K" & nDkisai).Value = wsD.Range("K" & nDkisai - 1).Value _
                                    + wsD.Range("I" & nDkisai).Value _
                                    + wsD.Range("J" & nDkisai).Value
        End If
        nDkisai = nDkisai + 1
    Next
    Keisen
    PageSettei
    
End Sub

Private Sub Keisen()
    Range("B16:K19").Select
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    wsD.Range("B16:K" & nDkisai).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With

End Sub

Private Sub PageSettei()
    wsD.PageSetup.PrintArea = "$B$1:$K$" & nDkisai

End Sub

Private Sub NumShokyo()
    wsM.Activate
    Columns("A:A").ClearContents
    Range("A1").Activate

End Sub


3日がかりのその仕事、3分で終わらせる方法教えます。ガラパゴスタディーオンライン講座 ユーザー登録

本講座の動画一覧

  1. 【動画1】 発展編1 フォローメールセミナー 第1回
    【動画1】 発展編1 フォローメールセミナー 第1回 未習得
  2. 【動画2】 発展編1 フォローメールセミナー 第2回
    【動画2】 発展編1 フォローメールセミナー 第2回 未習得
  3. 【動画3】 発展編1 フォローメールセミナー 第3回
    【動画3】 発展編1 フォローメールセミナー 第3回 未習得
  4. 【動画4】 発展編1 フォローメールセミナー 第4回
    【動画4】 発展編1 フォローメールセミナー 第4回 未習得
  5. 【動画5】 発展編1 フォローメールセミナー 第5回
    【動画5】 発展編1 フォローメールセミナー 第5回 未習得
  6. 【動画6】 発展編1 フォローメールセミナー 第6回
    【動画6】 発展編1 フォローメールセミナー 第6回 未習得
  7. 【動画7】 発展編1 フォローメールセミナー 第7回
    【動画7】 発展編1 フォローメールセミナー 第7回 未習得
  8. 【動画8】 発展編1 フォローメールセミナー 第8回
    【動画8】 発展編1 フォローメールセミナー 第8回 未習得
  9. 【動画9】 発展編1 フォローメールセミナー 第9回
    【動画9】 発展編1 フォローメールセミナー 第9回 未習得
  10. 【動画10】 発展編1 フォローメールセミナー 第10回
    【動画10】 発展編1 フォローメールセミナー 第10回 未習得
  11. 【動画11】 午後のフォローアップ No.1
    【動画11】 午後のフォローアップ No.1 未習得
  12. 【動画12】 発展編1 フォローメールセミナー 第11回
    【動画12】 発展編1 フォローメールセミナー 第11回 未習得
  13. 【動画13】 午後のフォローアップ No.2
    【動画13】 午後のフォローアップ No.2 未習得
  14. 【動画14】 発展編1 フォローメールセミナー 第12回
    【動画14】 発展編1 フォローメールセミナー 第12回 未習得
  15. 【動画15】 午後のフォローアップ No.3
    【動画15】 午後のフォローアップ No.3 未習得
  16. 【動画16】 発展編1 フォローメールセミナー 第13回
    【動画16】 発展編1 フォローメールセミナー 第13回 未習得
  17. 【動画17】 午後のフォローアップ No.4
    【動画17】 午後のフォローアップ No.4 未習得
  18. 【動画18】 発展編1 フォローメールセミナー 第14回
    【動画18】 発展編1 フォローメールセミナー 第14回 未習得
  19. 【動画19】 午後のフォローアップ No.5
    【動画19】 午後のフォローアップ No.5 未習得
  20. 【動画20】 発展編1 フォローメールセミナー 第15回
    【動画20】 発展編1 フォローメールセミナー 第15回 未習得
  21. 【動画21】 午後のフォローアップ No.6
    【動画21】 午後のフォローアップ No.6 未習得
  22. 【動画22】 発展編1 フォローメールセミナー 第16回
    【動画22】 発展編1 フォローメールセミナー 第16回 未習得
  23. 【動画23】 午後のフォローアップ No.7
    【動画23】 午後のフォローアップ No.7 未習得
  24. 【動画24】 発展編1 フォローメールセミナー 第17回
    【動画24】 発展編1 フォローメールセミナー 第17回 未習得
  25. 【動画25】 午後のフォローアップ No.8
    【動画25】 午後のフォローアップ No.8 未習得
  26. 【動画26】 発展編1 フォローメールセミナー 第18回
    【動画26】 発展編1 フォローメールセミナー 第18回 未習得
  27. 【動画27】 午後のフォローアップ No.9
    【動画27】 午後のフォローアップ No.9 未習得
  28. 【動画28】 発展編1 フォローメールセミナー 第19回
    【動画28】 発展編1 フォローメールセミナー 第19回 未習得
  29. 【動画29】 午後のフォローアップ No.10
    【動画29】 午後のフォローアップ No.10 未習得
  30. 【動画30】 発展編1 フォローメールセミナー 第20回
    【動画30】 発展編1 フォローメールセミナー 第20回 未習得
  31. 【動画31】 午後のフォローアップ No.11
    【動画31】 午後のフォローアップ No.11 未習得
  32. 【動画32】 発展編1 フォローメールセミナー 第21回
    【動画32】 発展編1 フォローメールセミナー 第21回 未習得
  33. 【動画33】 午後のフォローアップ No.12
    【動画33】 午後のフォローアップ No.12 未習得
  34. 【動画34】 発展編1 フォローメールセミナー 第22回
    【動画34】 発展編1 フォローメールセミナー 第22回 未習得
  35. 【動画35】 午後のフォローアップ No.13
    【動画35】 午後のフォローアップ No.13 未習得
  36. 【動画36】 発展編1 フォローメールセミナー 第23回
    【動画36】 発展編1 フォローメールセミナー 第23回 未習得
  37. 【動画37】 午後のフォローアップ No.14
    【動画37】 午後のフォローアップ No.14 未習得
  38. 【動画38】 発展編1 フォローメールセミナー 第24回
    【動画38】 発展編1 フォローメールセミナー 第24回 未習得
  39. 【動画39】 午後のフォローアップ No.15
    【動画39】 午後のフォローアップ No.15 未習得
  40. 【動画40】 発展編1 フォローメールセミナー 第25回
    【動画40】 発展編1 フォローメールセミナー 第25回 未習得
  41. 【動画41】 午後のフォローアップ No.16
    【動画41】 午後のフォローアップ No.16 未習得
  42. 【動画42】 発展編1 フォローメールセミナー 第26回
    【動画42】 発展編1 フォローメールセミナー 第26回 未習得
  43. 【動画43】 午後のフォローアップ No.17
    【動画43】 午後のフォローアップ No.17 未習得
  44. 【動画44】 発展編1 フォローメールセミナー 第27回
    【動画44】 発展編1 フォローメールセミナー 第27回 未習得
  45. 【動画45】 午後のフォローアップ No.18
    【動画45】 午後のフォローアップ No.18 未習得
  46. 【動画46】 発展編1 フォローメールセミナー 第28回
    【動画46】 発展編1 フォローメールセミナー 第28回 未習得
  47. 【動画47】 午後のフォローアップ No.19
    【動画47】 午後のフォローアップ No.19 未習得
  48. 【動画48】 発展編1 フォローメールセミナー 第29回
    【動画48】 発展編1 フォローメールセミナー 第29回 未習得
  49. 【動画49】 午後のフォローアップ No.20
    【動画49】 午後のフォローアップ No.20 未習得
  50. 【動画50】 発展編1 フォローメールセミナー 第30回
    【動画50】 発展編1 フォローメールセミナー 第30回 未習得
  51. 【動画51】 午後のフォローアップ 最終回
    【動画51】 午後のフォローアップ 最終回 未習得

塾長 小川慶一

メニュー

コメント紹介

もっと見る

ページの先頭へ