加藤さん:

こんにちは。

ひととおり、拝見しました。

講座で解説しているやり方と異なるものについては、なぜあえてこういうやり方をしたのか、そして、そのやり方を採用したことのメリット・デメリットは何かということについてコメントをお願いします。

ぱっと見て、たとえば、以下は聞いてみたくなりますね。

[1] 見本と異なり、提出物では、プロシージャを分割せず、その総数を減らしたのはなぜか。
そのメリット・デメリットは？
もしデメリットがあるにも関わらずそうしたならば、なぜ、あえてそうしたのか。

[2] 見本と異なり、提出物では、罫線を引くマクロは、唯一のForNextループ内で、元データからのデータ転記の都度実行されるようになっている。
そのメリット・デメリットは？
もしデメリットがあるにも関わらずそうしたならば、なぜ、あえてそうしたのか。

[3] 見本と異なり、提出物では、罫線をクマクロでは、 Selec. Selection という言葉が残っている。
そのメリット・デメリットは？
もしデメリットがあるにも関わらず残したならば、なぜ、あえてそうしたのか。

[4] 並べ替えのマクロは、ForNextループの前にあるものと後にあるものでコーディングスタイルが異なっている。
そのメリット・デメリットは？
もしデメリットがあるにも関わらずそうしたならば、なぜ、あえてそうしたのか。

受講生 さん:

おはようございます。

> インデント整えて再提出致します。

完璧です。

意識して行えばいろいろしっかりできるご様子ですので、そこは安心です。
今後とも、楽しんで学習を進めてください (^^*

受講生 さん:

おはようございます。

とても良くかけていると思います。
ご自身の感想としてはどうでしょうか。

もう、この課題については自信を持たれているものと思います。
いかがでしょうか。

コード内で、インデントに関してコメントしました。2箇所です。
sub tenki 内はインデントを整えて再提出してください。
インデントを整えることは可読性を向上させます。可読性が向上すると、より複雑なマクロでも混乱なく読める＆書ける＆編集できるようになります。

インデントを整理するときの考え方のポイントは、「どのコードは、どのブロックの中の部品なのか？」ということを明確にすることです。
青い文字で対になっている言葉がありますね。
sub ... end sub, for ... next, if ... (else) ... end if 等。これらの中身は、「そのブロックの中の部品」なので、そうと識別しやすいように、一段右に移動させまず。

ひきつづき、学習お楽しみください (^^

Option Explicit
    '以下の3行はインデントしない。
    Dim S_main As Worksheet
    Dim S_hina As Worksheet
    Dim saigo As Long
Sub zentai()
    Set S_main = Worksheets("main")
    Set S_hina = Worksheets("main1")
    saigo = S_main.Range("B65536").End(xlUp).Row
    anum
    bnara
    fuyokeshi
    tenki '中にkeisen
    anara
End Sub
Sub anum()
    Dim n As Long
    For n = 2 To saigo
        S_main.Range("A" & n).Value = n - 1
    Next
End Sub

Sub bnara()
    Range("A1:G317").Sort _
        key1:=Range("B1"), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub

Sub anara()
    Range("A1:G317").Sort _
        key1:=Range("A1"), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub
Sub fuyokeshi()
    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 tenki()
    Dim mgyo As Long
    Dim mtori As String
    Dim S_copy As Worksheet
    Dim copygyo
    Dim dt As Date
       For mgyo = 2 To saigo
    mtori = S_main.Range("B" & mgyo).Value
        If mtori <> S_main.Range("B" & mgyo - 1).Value Then
            If mgyo > 2 Then
                keisen
            End If
            copygyo = 16
            S_hina.Copy after:=Sheets(2)
            Set S_copy = ActiveSheet
            S_copy.Name = mtori
        End If
     S_copy.Range("E" & copygyo).Value = S_main.Range("D" & mgyo).Value
     S_copy.Range("F" & copygyo).Value = S_main.Range("E" & mgyo).Value
     S_copy.Range("H" & copygyo).Value = S_main.Range("F" & mgyo).Value
     dt = S_main.Range("C" & mgyo).Value
     S_copy.Range("B" & copygyo).Value = Right(Year(dt), 2)
     S_copy.Range("C" & copygyo).Value = Month(dt)
     S_copy.Range("D" & copygyo).Value = Day(dt)
     If S_main.Range("G" & mgyo).Value > 0 Then
        S_copy.Range("J" & copygyo).Value = S_main.Range("G" & mgyo).Value
     Else
        S_copy.Range("I" & copygyo).Value = S_main.Range("G" & mgyo).Value
     End If
     If copygyo = 16 Then
        S_copy.Range("K" & copygyo).Value = S_main.Range("G" & mgyo).Value
     Else
        S_copy.Range("K" & copygyo).Value = S_main.Range("G" & mgyo).Value + S_copy.Range("K" & copygyo - 1).Value
     End If
     copygyo = copygyo + 1
    Next
    keisen
    S_main.Select
End Sub
Sub keisen()
    Dim copysaigo As Long
    copysaigo = Range("B65536").End(xlUp).Row
    With Range("B16:K" & copysaigo)
    '以下の with 直下の2行はインデントする。
    .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

受講生 さん:

追記です。

> ほとんど何も見ずにできたことに感動しました。

ということですので、全体の理解(知識)という意味では良いところまで到達しているかと思います。
なので、「少し腕力をつけましょう」というところです。

受講生 さん:

おはようございます。
ご自身でのご検討のとおりです。

書けば書くほど、書いてから講座を復習すればするほど上達する時期ですので、慌てて先に進まず、ここはじっくり実力の土台がために時間を使ってください。

「動画で学ぶ」というのも、角度の違うよい復習方法になるかもしれません。
https://online.pc5bai.com/package/index/26/

受講生 さん:

おはようございます。

> ほとんど何も見ずにできたことに感動しました。

良かったです。
まずは、おめでとうございます☆


ひととおり、拝見しました。

「荒削り」からの次のステップです。

講座で解説しているやり方と異なるものについては、なぜあえてこういうやり方をしたのか、そして、そのやり方を採用したことのメリット・デメリットは何かということについてコメントをお願いします。

ぱっと見て、たとえば、以下は聞いてみたくなりますね。

[1] 全体に、インデントのルールがお手本と違うが、あえて違うやり方にした理由は？そのメリット・デメリットは？
[2] 罫線を引くマクロは、お手本と異なり、メインのプロシージャから呼び出すようしているが、あえて違うやり方にした理由は？そのメリット・デメリットは？
[4] 転記を実行するマクロは、お手本と異なり、 If文の中身の量が多くなっているが、あえて違うやり方にした理由は？そのメリット・デメリットは？
[3] 罫線を引くマクロは、お手本と異なり、 Select, Selection という言葉が残ったままにしているが、あえて違うやり方にした理由は？そのメリット・デメリットは？

提出物への受講生さんの検討がどれだけの深さだったのかによって、コメントの内容も変わります。

「再検討をした結果、書き直したくなった」ということでしたら、再提出も歓迎します。
書けば書くほど、書き上げてから復習するほど、上達する時期です。楽しんで学習してください。

このページの12805のコメントからのやりとりも、「どうしてこういう返信が来たのか」ということを察するための参考になるかと思います。

受講生 さん:

おはようございます。

> 2・3回目は手順や書いているマクロの動作がしっかりとイメージできました。
> 完成までに要した時間は、1回目→90分、2回目→70分、3回目→50分です。
> 楽しみながら集中力も鍛えられて良かったです。

よいですね。
集中力がついた感じと同時に、書き上げるのに必要な集中力の水準がどんどん下がっていったことも感じられたのではないでしょうか。

あるマクロを書き上げるのに必要な集中力のレベルが下がると、その分、そのパターンを応用していろいろなことをできるようになります。

> 元に戻すマクロもついでに作るなどして、手際良く進められました。

↑これなどは、まさにその顕れですね。

実は、この「伝票作成」の課題だけでなく、ご提供している演習は、すべて、こういう感じでやっていただきたいのです。
楽に書き上げられるマクロのレパートリーが増えれば増えるほど、現場でエクセルファイルを見るたびにつぎつぎとアイデアが沸いてどんどんマクロを書けるようになります。

「『試行錯誤しながらの2時間半』だけでモヤモヤした感想だけを抱いたまま知識だけを追い求める」か、「全体像を感じながら課題をサラサラと解けるようになる楽しみを味わいつつ学び続ける」かで、得られる成果は大きく変わります。

ぜひ、今回得られたその感覚を活かして、他の演習も楽しみつつとりくんでみてください。

この「伝票作成」の課題も、全体のプロセスで改善できそうな点があるようでしたら、まだまだ所要時間つめられると思います。
いけるところまで行ってみてください☆

受講生 さん:

こんばんは。
投稿ありがとうございます。

> ①見直しに時間を使った

良いことだと思います。

> ②考えると手が止まってしまう

考えることに集中すること自体は悪いないです。

> ③手順が細分化できていない
> スタート→ゴールに至るまでの手順が大雑把であったため、途中で手順の追加や見直しが発生しました。

これは、慣れですね。
まだ手についてない技術があるということです。もう2-3回同じ課題に連続して取り組むと、課題を見た瞬間に見えるやるべきことの全体像の解像度があがることかと思います。
試しに、騙されたと思って、この課題を連続で3回くらい書ききってみてください。それから、「スタート→ゴールに至るまでの手順」を思い浮かべてみてください。きっと、その鮮明さにご自身で驚かれることと思います。

完成品のクオリティが高いので、そこは安心です。
ぜひ、やってみてください。それから、もし気が向いたならば、やってみた感想をまた投稿してください。

受講生 さん:

提出物を確認しました。
とても良くかけていると思います。特に指摘したい点はありません。

まずはお聞きしたいのですが、2時間半かかった理由はどういうところにありそうでしょうか。
そして、どのようにすればそこを短縮できそうでしょうか。
3項目程度挙げていただければと思います。

らりおさん:

こんにちは。

添削を返送します。

ひきつづき、よい学びを！

Option Explicit
    Public Moto As Worksheet
    Public Saki As Worksheet
    Public saigo As Long
    Public gyo As Long
    Public Tenki As Worksheet
Sub denpyosakusei()
    Dim hiduke As Date
    Dim kakidasi As Long
    Dim kingaku As Long
    Dim zandaka As Long
    
    Set Saki = Workbooks("s09_homework").Worksheets("main1")
    Set Moto = Workbooks("s09_homework").Worksheets("main")
    saigo = Moto.Range("B" & Moto.Rows.Count).End(xlUp).Row
    
    denpyosyokyo
    
    '作成前のシート"main"の並べ替え
    id
    hiduke_narabe
    b_narabe
    
    'シート作成＆転記
    For gyo = 2 To saigo
        If Moto.Range("B" & gyo).Value <> Moto.Range("B" & gyo - 1).Value Then
            kakidasi = 16
            zandaka = 0
            Saki.Copy After:=Sheets(Worksheets.Count)
            Set Tenki = ActiveSheet
            Tenki.Name = Moto.Range("B" & gyo).Value
        End If
        hiduke = Moto.Range("C" & gyo).Value
        kingaku = Moto.Range("G" & gyo).Value
        Tenki.Range("B" & kakidasi).Value = Right(Year(hiduke), 2)
        Tenki.Range("C" & kakidasi).Value = Month(hiduke)
        Tenki.Range("D" & kakidasi).Value = Day(hiduke)
        Tenki.Range("E" & kakidasi & ":F" & kakidasi).Value = Moto.Range("D" & gyo & ":E" & gyo).Value
        Tenki.Range("H" & kakidasi).Value = Moto.Range("F" & gyo).Value
        Select Case kingaku
            Case Is >= 0
                Tenki.Range("I" & kakidasi).Value = kingaku
            Case Else
                Tenki.Range("J" & kakidasi).Value = kingaku
        End Select
        zandaka = zandaka + kingaku
        Tenki.Range("K" & kakidasi).Value = zandaka
        
        '掛線
        If Moto.Range("B" & gyo).Value <> Moto.Range("B" & gyo + 1).Value Then
            With Tenki.Range("B16" & ":K" & kakidasi)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).Weight = xlThin
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).Weight = xlThin
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeRight).Weight = xlThin
            End With
            If zandaka < 0 Then  '最終残高がマイナスの時、タブの色を赤にするアレンジ
                Tenki.Tab.Color = vbRed
            End If
        End If
        kakidasi = kakidasi + 1
    Next
    
    Moto.Select 'シート"main"を元に戻す
    id_narabe
    Moto.Columns("A:A").ClearContents
End Sub
Sub id()
    Set Moto = Workbooks("s09_homework").Worksheets("main")
    saigo = Moto.Range("B" & Moto.Rows.Count).End(xlUp).Row
    
    Moto.Range("A1").Value = "No."
    For gyo = 2 To saigo
        Moto.Range("A" & gyo).Value = gyo - 1
    Next
End Sub
Sub b_narabe()
    Set Moto = Workbooks("s09_homework").Worksheets("main")
    saigo = Moto.Range("B" & Moto.Rows.Count).End(xlUp).Row
    
    Moto.Sort.SortFields.Clear
    Moto.Sort.SortFields.Add Key:=Range("B2:B" & saigo)
    With Moto.Sort
        .SetRange Range("A1:G" & saigo)
        .Header = xlYes
        .Apply
    End With

End Sub
Sub id_narabe()
    Set Moto = Workbooks("s09_homework").Worksheets("main")
    saigo = Moto.Range("B" & Moto.Rows.Count).End(xlUp).Row
    
    Moto.Sort.SortFields.Clear
    Moto.Sort.SortFields.Add Key:=Range("A2:A" & saigo)
    With Moto.Sort
        .SetRange Range("A1:G" & saigo)
        .Header = xlYes
        .Apply
    End With

End Sub
Sub hiduke_narabe()
    Set Moto = Workbooks("s09_homework").Worksheets("main")
    saigo = Moto.Range("B" & Moto.Rows.Count).End(xlUp).Row
    
    Moto.Sort.SortFields.Clear
    Moto.Sort.SortFields.Add Key:=Range("C2:C" & saigo)
    With Moto.Sort
        .SetRange Range("A1:G" & saigo)
        .Header = xlYes
        .Apply
    End With

End Sub

Sub denpyosyokyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If InStr(ws.Name, "main") = 0 Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

受講生 さん:

考え方の基本は、やはり、DPRです。
「Pの最適化」ですね。

慣れてくると自然にいろいろと気づけるようにもなるかと思います。

ゲストさん:

> >'ひとつのセルの指定では ("行" & 変数) と .offset( ) の両方を使うよりどちらかだけにしたほうがよいです。
> こちらについてですが、どちらかだけにした方が良いのはどうしてなのか分かりません。動作に支障がでるのでしょうか？

動作への支障はないです。

以下ソースコードの[A], [B]を読み比べてみてください。どちらのほうが、より目移りせずに値入力先のセルを見いだせるでしょうか。
また、メンテナンス性についてはどうでしょうか。

Sub RangeShitei()
    Dim gyo
    gyo = 5
    
    Dim tate
    Dim yoko
    tate = 5
    yoko = 3
    
    Range("A" & gyo).Offset(, yoko).Value = "[A] 両方組み合わせた場合"
    Range("A1").Offset(tate, yoko).Value = "[B] Offsetのみの場合"
End Sub

発想としては、エクセルワークシート関数とマクロを組み合わせるより、マクロだけのほうがよい。
アクセスとエクセルを組み合わせるより、エクセルだけのほうがよい。
といったことと同様です。同じことを実現するのであれば、ひとつの技術だけで済ませたほうが良いです。
その理由は、使う技術が少ないほうが、集中を向けるべき事項が減ること、メンテナンス性が高いことです。
DPRで言うと、「P」をシンプルにするということです。
https://www.exvba.com/dpr.php

ゲストさん:

だいぶ良くなったと思います。
コメントを返送します。

自分で書いて、自分で検討すると、よく学べます☆

Option Explicit
Public Sub CreateDenpyo()
    WriteNum
    Sort_By_Torihikisaki
    ExeCreateDenpyo
    Sort_By_No
End Sub
Private Sub ExeCreateDenpyo()
    Denpyosakujo ''ここで伝票削除プロシージャの呼び出し
    Dim num As Long
    Dim gyo As Long
    Dim saki As Long
    Dim wFr As Worksheet
    Set wFr = Worksheets("main")
    Dim wFr1 As Worksheet
    Set wFr1 = Worksheets("main1")
    Dim wTo As Worksheet
    Dim namae As String
    Dim ws As Worksheet
    Dim dt As Date
    
    For gyo = 2 To wFr.Range("B" & Rows.Count).End(xlUp).Row
        If wFr.Range("B" & gyo).Value <> namae Then
            If gyo > 2 Then
                Keisen
            End If
            namae = wFr.Range("B" & gyo).Value
            wFr1.Copy After:=Sheets(2)
            Set wTo = ActiveSheet
            wTo.Range("H2").Value = namae
            wTo.Name = namae
            saki = 16
        End If
        
        wTo.Range("E" & saki).Value = wFr.Range("D" & gyo).Value
        wTo.Range("F" & saki).Value = wFr.Range("E" & gyo).Value
        wTo.Range("H" & saki).Value = wFr.Range("F" & gyo).Value
        If wFr.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & saki).Value = wFr.Range("G" & gyo).Value ''借方・貸方の入力先が逆でしたので訂正しました
        Else
            wTo.Range("J" & saki).Value = wFr.Range("G" & gyo).Value
        End If
        If gyo = 16 Then
            wTo.Range("K" & saki).Value = wFr.Range("G" & gyo).Value
        Else
            wTo.Range("K" & saki).Value = wFr.Range("G" & gyo).Value + wTo.Range("K" & saki).Offset(-1).Value 'ひとつのセルの指定では ("行" & 変数) と .offset( ) の両方を使うよりどちらかだけにしたほうがよいです。
        End If
        dt = wFr.Range("C" & gyo).Value
        wTo.Range("B" & saki).Value = Right(Year(dt), 2) '’日付の変数を作成しました
        wTo.Range("C" & saki).Value = Month(dt)
        wTo.Range("D" & saki).Value = Day(dt)
        saki = saki + 1
    Next
    Keisen
    wFr.Activate
End Sub
Public Sub Denpyosakujo()
    Dim w As Worksheet
    Application.DisplayAlerts = False
    For Each w In Worksheets
        If Left(w.Name, 4) <> "main" Then
            w.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Private Sub WriteNum()
    Dim ln As Long
    Dim lnMx As Long
    Range("A1").Value = "No."
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    For ln = 2 To lnMx
        Range("A" & ln).Value = ln - 1
    Next
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
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 = xlDot
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlDot
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With

End Sub

ゲストさん:

こんにちは。

いくつかコメントを入れました。
まずは返送します。

他にも議論すべき点はありますが、まずは、以下にあるコメントを参考のうえ、講座で説明している見本との比較をご自身でしてください。
講座で説明しているものとは異なる手法を使ったものについては、再提出時は、以下を述べてください。
[a] その手法をあえて取ることのメリットは何か
[b] その手法をあえて取ることのデメリットは何か
[c] なぜあえてその手法を取ったのか

たとえば denpyosakusei の中で Denpyosakujo を呼び出さないことについてならば、以下のような感じでしょうか。

[a]
「他のプロシージャを呼び出す」という、より高度な技術を用いないで済む。
書くことが減って、コーディングが楽。

[b]
伝票作成ボタンを２回連続で押したとき、２回目はエラーで停止する。なので、利用者には、「伝票がすでにある場合は、先に『伝票削除』ボタンを押してください」と案内しなくてはならない。
エラーで停止すると「main1 (2)」という名前のシートがゴミとして残るので、手動で削除する手間が発生する。
動作テストのときにもやることがひと手間多く、いちいち面倒。

[c]
([a], [b]比較のうえ、あえてこのやり方で行こうと決めた理由を述べる)

これをやると、よい学びになりますよ。

'Option Explicit '入れましょう。モジュール生成時に自動で付加されない場合は、VBEの初期設定確認しましょう。
'以下のプロシージャ内の、具体的な処理がはじまる前のタイミングで、 Denpyosakujo を呼び出したい。
'でないと、伝票作成ボタンを２回連続で押したとき、２回目はエラーで停止する
Sub denpyosakusei()
    Dim num As Long
    Dim gyo As Long
    Dim saki As Long
    Dim wFr As Worksheet
    Set wFr = Worksheets("main")
    Dim wFr1 As Worksheet
    Set wFr1 = Worksheets("main1")
    Dim wTo As Worksheet
    Dim namae As String
    Dim ws As Worksheet
    
    For num = 2 To wFr.Range("B" & Rows.Count).End(xlUp).Row
        wFr.Range("A" & num).Value = num - 1
    Next
    wFr.Sort.SortFields.Clear
    wFr.Sort.SortFields.Add2 Key:=wFr.Range("B2:B317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With wFr.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    saki = 16
    For gyo = 2 To wFr.Range("B" & Rows.Count).End(xlUp).Row
        If wFr.Range("B" & gyo).Value <> namae Then
            If gyo <> 2 Then
                With wTo.Range("B16:K" & saki) '[1-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 = xlThin
                    End With
                End With
            End If
            saki = 16
            wFr1.Copy After:=Sheets(2)
            namae = wFr.Range("B" & gyo).Value
            Set wTo = ActiveSheet
            wTo.Range("H2").Value = namae
            wTo.Name = namae
            wTo.Range("B" & saki).Value = Right(Year(wFr.Range("C" & gyo).Value), 2) '[2-1]
            wTo.Range("C" & saki).Value = Month(wFr.Range("C" & gyo).Value)
            wTo.Range("D" & saki).Value = Day(wFr.Range("C" & gyo).Value)
            wTo.Range("E" & saki).Value = wFr.Range("D" & gyo).Value
            wTo.Range("F" & saki).Value = wFr.Range("E" & gyo).Value
            wTo.Range("H" & saki).Value = wFr.Range("F" & gyo).Value
            If wFr.Range("G" & gyo).Value > 0 Then
                wTo.Range("J" & saki).Value = wFr.Range("G" & gyo).Value
            Else
                wTo.Range("I" & saki).Value = wFr.Range("G" & gyo).Value
            End If
            If gyo = 16 Then
                wTo.Range("K" & saki).Value = wFr.Range("G" & gyo).Value
            Else
                wTo.Range("K" & saki).Value = wTo.Range("K" & saki - 1).Value + wFr.Range("G" & gyo).Value
            End If
            saki = saki + 1
        Else
            wTo.Range("H2").Value = wFr.Range("B" & gyo).Value '[2-2] [2-1]と以下は内容がかぶっていますね。End If以降で、一回書くだけにするべきでしょう。
            wTo.Range("B" & saki).Value = Right(Year(wFr.Range("C" & gyo).Value), 2)
            wTo.Range("C" & saki).Value = Month(wFr.Range("C" & gyo).Value)
            wTo.Range("D" & saki).Value = Day(wFr.Range("C" & gyo).Value)
            wTo.Range("E" & saki).Value = wFr.Range("D" & gyo).Value
            wTo.Range("F" & saki).Value = wFr.Range("E" & gyo).Value
            wTo.Range("H" & saki).Value = wFr.Range("F" & gyo).Value
            If wFr.Range("G" & gyo).Value > 0 Then
                wTo.Range("J" & saki).Value = wFr.Range("G" & gyo).Value
            Else
                wTo.Range("I" & saki).Value = wFr.Range("G" & gyo).Value
            End If
            If gyo = 16 Then
                wTo.Range("K" & saki).Value = wFr.Range("G" & gyo).Value
            Else
                wTo.Range("K" & saki).Value = wTo.Range("K" & saki - 1).Value + wFr.Range("G" & gyo).Value
            End If
            saki = saki + 1
        End If
    Next
    With wTo.Range("B16:K" & saki) '[1-2] [1-1]と同一内容なので別モジュールにしたい。そうすることには、[1-1]のIf文分岐内のコード量が減って全体の流れが見えやすくなるというメリットもあります。
        .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
    
    wFr.Sort.SortFields.Clear
    wFr.Sort.SortFields.Add2 Key:=wFr.Range("A2:A317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With wFr.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    wFr.Range("A1:A317").ClearContents
    For Each ws In Worksheets
        ws.Activate
        ws.Range("A1").Select
    Next
End Sub

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

たかちゃんさん:

おはようございます。
もはや、あまりコメントはないです...。先日お見せしたアレンジを参考にしてください。

ひとつだけ書くなら、Range.Borders について。

Borders(カッコ)となっていますね。コレクションです。
コレクションの要素は、それぞれ、以下の意味。

.Borders(xlDiagonalDown) '右肩下がり(の、斜め線)
.Borders(xlDiagonalUp) '右肩上がり(の、斜め線)
.Borders(xlEdgeLeft) '左側のエッジ(縁)
.Borders(xlEdgeTop) '天井のエッジ(縁)
.Borders(xlEdgeBottom) '底のエッジ(縁)
.Borders(xlEdgeRight) '右側のエッジ(縁)
.Borders(xlInsideVertical) '中の縦線
.Borders(xlInsideHorizontal) '中の水平線

エクセルのダイアログ[書式]→[罫線]で線を引く場所として選択できる項目と一致しています。

ps.
プログラムを投稿する際のヒントを以下に記載しています。
https://online.pc5bai.com/Faq/view/28

受講生 さん:

おはようございます。

添削を返送します。

> Q1:罫線に関して
> 取引先毎に罫線を引く作業ですが、あえて私は分けずに書いてみました。罫線に関しては小川さんが解説したとおり、サブプロシージャーに分けたほうがよろしいでしょうか？

両者のメリット・デメリットについてご自身で考えられたようでしたら、まずは、その検討内容と、その検討を経て提出いただいたマクロで採用した方法を選んだ理由をお聞かせください (^^


> Q2:変数名に関して
> 他のプロシージャーで同じ変数を使っています。
> ex:WkFm、WkTo、CFmMax等
>
> 別のプロシージャーで同じ変数を使っていると、あまり綺麗ではないと感じています。変数名は異なる名前にしたほうがよろしいでしょうか？

むしろ、本当は同じ機能を持たせる変数であれば、同じ名前にするほうが良いです。
講座内（特に基礎編）で別プロシージャ内で宣言する変数に対して同様の機能のものでも僕があえて違う名前にしているのは、そうしないと理解が足りない受講生がどこで宣言した変数がどこにどう機能しているか分からず混乱することがあるからです。
そういう混乱がない場合、自分のパターンとして「最終行の行番号を格納する変数は Cmx とする」等固定したほうがマクロは書きやすくなります。


> Q3:プロシージャー名に関して
> 気の利いた名前が思いつかないので、結構適当になりました。
> 小川さんがプロシージャーの名前を付けるときに意識していることをご教示できればと思います。

いただいたサンプルのもので悪くないと思いますよ。
僕は、単語２語以上にすることが多いですね。「何を、どうする」あるいは、「どうする、何を」と、名詞と動詞を組み合わせます。

Denpyo_Create

とかはまさにそんな感じ。

denpyo_create (スネークケース)
DenpyoCreate (パスカルケース)
denpyoCreate (キャメルケース)

...等々、単語のつなげ方のいろいろなパターンに対して俗称がついていたりします。
言語によっては、「変数名には○○ケースを推奨」というのがあったりします。エクセルVBAには特にそういうのはありません。

'提出時は、不要なモジュールは削除しましょう(module2, module3, module4)
'sub ... endsub 内は一段インデントを入れましょう
'試してみるとわかりますが、そのほうが読みやすいです。
Option Explicit

Sub main()
No_Create
Torihiki_Ascending_Order
Denpyo_Create
No_Ascending_Order
No_Reset
End Sub

'伝票作成
Sub Denpyo_Create()
Depyo_Delete
Dim WkFm As Worksheet
Dim WkTo As Worksheet
Dim CFm As Long
Dim CFmMax As Long
Dim CTo As Long
Dim DFm As Date
Dim CSum As Long
Dim SName As String

Set WkFm = Worksheets("main")
CFmMax = WkFm.Range("B65536").End(xlUp).Row

For CFm = 2 To CFmMax
    If SName <> WkFm.Range("B" & CFm).Value Then
        '取引先毎にsheetを作成
        CTo = 16
        SName = WkFm.Range("B" & CFm).Value
        Sheets("main1").Copy After:=Sheets(2)
        Sheets("main1 (2)").Name = SName
        Set WkTo = ActiveSheet
    End If
   '↓上の if ... endif と比較してインデントがズレていますね。インデント操作は [Tab] キーで行いましょう。
   '  レイアウト崩れは可読性の低下を生みます。ついては、より高度なマクロを書く際の障害になります。
   '  このプロシージャ内、他も全部インデント崩れについて確認・修正してください。
   '会計番号､信憑番号を新規作成したsheetへ転記
   WkTo.Range("E" & CTo).Value = WkFm.Range("D" & CFm).Value
   WkTo.Range("F" & CTo).Value = WkFm.Range("E" & CFm).Value
   
   '新規作成したsheetへ取引金額を転記
   CSum = WkFm.Range("G" & CFm).Value
   If CSum > 0 Then
        WkTo.Range("I" & CTo).Value = CSum
   Else
        WkTo.Range("J" & CTo).Value = CSum
   End If
   
   '新規作成したsheetへ西暦､何月、何日を転記
    DFm = WkFm.Range("C" & CFm).Value
    WkTo.Range("B" & CTo).Value = Right(Year(DFm), 2)
    WkTo.Range("C" & CTo).Value = Month(DFm)
    WkTo.Range("D" & CTo).Value = Day(DFm)
    
    '新規作成したsheetへ残高の計算を行う
    WkTo.Range("K" & CTo).Value = WkTo.Range("K" & CTo - 1).Value + CSum
     
   '新規作成したsheetへ罫線を取引数に応じた行数だけ作成
   'Q　僕の場合は下記のように記載。小川さんが解説してる通り､サブプロシージャー作成して分けるべきでしょうか？
    With Range("B" & CTo & ":" & "K" & CTo)
     .Borders(xlEdgeTop).LineStyle = xlContinuous
     .Borders(xlEdgeBottom).LineStyle = xlContinuous
     .Borders(xlEdgeRight).LineStyle = xlContinuous
     .Borders(xlEdgeLeft).LineStyle = xlContinuous
     .Borders(xlInsideVertical).LineStyle = xlContinuous
     .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
   CTo = CTo + 1
Next
End Sub

'sheet「mainの」A列へ番号を記入
Sub No_Create()
Dim CFm As Long
Dim WkFm As Worksheet
Set WkFm = Worksheets("main")
Dim CFmMax As Long
WkFm.Range("A1").Value = "No"
CFmMax = WkFm.Range("B65536").End(xlUp).Row

For CFm = 2 To CFmMax
    WkFm.Range("A" & CFm).Value = CFm - 1
Next

End Sub
'sheet「main」B列を昇順に並び替え
Sub Torihiki_Ascending_Order()
Dim WkFm As Worksheet
Dim CFmMax As Long
Set WkFm = Worksheets("main")
'**取引数が追加された場合を想定して下記の変数を追加**
CFmMax = WkFm.Range("G65536").End(xlUp).Row

 WkFm.Range("A1" & ":" & "G" & CFmMax).Sort _
 Key1:=WkFm.Range("B1"), _
 Order1:=xlAscending, _
 Header:=xlYes
End Sub

'sheet「main」A列を昇順に並び替え
Sub No_Ascending_Order()
Dim WkFm As Worksheet
Dim CFmMax As Long
Set WkFm = Worksheets("main")
'**取引数が追加された場合を想定して下記の変数を追加**
CFmMax = WkFm.Range("G65536").End(xlUp).Row

 WkFm.Range("A1" & ":" & "G" & CFmMax).Sort _
 Key1:=WkFm.Range("A1"), _
 Order1:=xlAscending, _
 Header:=xlYes
End Sub

'main1とmain以外のsheetを削除
Sub Depyo_Delete()
Dim Wks As Worksheet

'以下の[1], [2]が気になりますね。
For Each Wks In Worksheets
    Application.DisplayAlerts = False '[1] これはループの回数分だけくりかえされる。
    If Left(Wks.Name, 4) <> "main" Then
        Wks.Delete
    End If
Next
    Application.DisplayAlerts = True '[2]これは、一回しか実行されない。
End Sub
'念のため最後にA列のシートを初期化(多分これは必要ないと思う。)
Sub No_Reset()
Dim WkFm As Worksheet
Set WkFm = Worksheets("main")
    WkFm.Columns("A:A").ClearContents
End Sub

受講生 さん:

お返事ありがとうございます。

>ご指摘頂いたモジュールレベル変数で、
>列を宣言する方法、大変勉強になりました。
>また前回、ナンバーを並べ替えるプロシージャの
>最後の部分にナンバーを消す処理を書いておりましたが、
>ご指摘頂いたプロシージャを分けることでとても見やすくなったと感じております。

「書いてみて、添削を受けて」というのは、上達の近道のひとつですね。


>一つお伺いしたいのですが、
>最終行を取得する変数をいろいろなプロシージャで宣言してしまいましたが、これらは混同しない用、同じ変数名を使用することは避けた方が宜しいでしょうか。
>
>ご教示の程、宜しくお願い致します。

「混同しないように」ということでしたら、別の変数名にするほうが無難です。
ですが、「自分は混同する心配はない」ということでしたら、同一の変数名にしたほうが良いかと思います。


以下に補足します。

まず、原則を書くと:
[1] プロシージャ内でしか利用しない変数については、他のプロシージャ内で宣言する場合も同一の名称でかまいません。
[2] 一方、同一の目的で利用する変数だからといって、「モジュールレベル変数をひとつ宣言して使い回す」というのは好ましくありません。

というところです。
上記については十分にご理解いただいているという前提で、回答します。
[1]のとおりなので、同じ変数名を使用することには問題ありません。というか、慣れてきたら、むしろそのほうが良いかと思います。
たとえば、「表の最終行の行番号を格納する変数はいつも cMx とする」等のパターンを作ってしまったほうが、生産性はあがります。

講座内で、あるいは演習で、僕が極力（たとえ別プロシージャに宣言する変数であっても）違う名前にしようとしているのは、（特に、導入編-基礎編初期のレベルの方ですと）「どこで宣言したどの変数がどこまでどう効いているのか？」ということを把握する力が未熟なため、「同一名の変数をあちこちで宣言していると、それだけで講座受講中に頭がクラクラして挫折してしまう」というケースがまま見られたからです。
（これは、その方のもともとの記号認知能力の問題でなく、慣れの問題です。僕自身、python等の別言語を学習するとき、初期には、サンプルコード内で同一名の変数やあるいは文字列が様々な箇所で登場するコードを読み解くにはかなり苦労しました）

ということで...。
再度結論を書くと、

・「混同しないように」ということでしたら、別の変数名にするほうが無難
・「自分は混同する心配はな」ということでしたら、同一の変数名にしたほうが良い

というところです。

受講生 さん:

おはようございます。

添削を返送します。
ひきつづき、学習お楽しみください (^^

Option Explicit
Dim sRetsu As String 'これをしてほしかった。
'Dim lngLastGyo As Long 'CalledCreateDenpyo内で宣言している変数と名前がかぶっています。混乱をさけるため、この変数を作るにしても、たとえばこちらは lngGLastGyo とかの名称にするのもありです。(G は Global、つまりモジュールレベル変数 という意味)
'↑調査を一度だけで済ませられるという意味ではこの変数を各モジュールで使い回すのはありです。が、そうすると結合度が高くなる（部品として使い回すのが大変になる等、別の面倒が発生する）ということで、このアイデアは採用しません。
'  （モジュールレベル変数の宣言は、最小限にするのが望ましいです。）
'  今の段階ではちょっと悶々とするところもあるかもしれません。が、発展編2で「引数付きプロシージャ」を学習するとこの手の悩みを解決できるようになります。
Public Sub CreateDenpyo2()
    InputNo
    
'    SortCltName
    sRetsu = "B"
    SortMainSheet
    
    DeleteSheets2 'DeleteNumについて述べたのと同様の理由でCalledCreateDenpyoから外に出しました。
    CalledCreateDenpyo

'    SortNo
    sRetsu = "A"
    SortMainSheet

    DeleteNum 'A列への値入力がCreateDenpyo内にあるなら、A列の値削除もCreateDenpyo内にあるほうがよいです。各プロシージャでの作業の粒度を統一すると可読性が増します
End Sub
Private Sub CalledCreateDenpyo()
    'ハンガリアン記法で行くなら、「小文字で型、大文字で意味」というスタイルがおすすめです。
    '例: 以下の要領
    'wsMa: ワークシート「main」の意味
    'wsMa1: ワークシート「main1」の意味
    'wsClt: ワークシートのうち、コントロール対象のものという意味
    'strCltName: 文字列のうち、コントロール対象シートの名前という意味
'    4ets
    Dim lngGyo As Long
    Dim lngGyoMx As Long
    Dim strCltName As String
    Dim wsMa As Worksheet
    Dim wsMa1 As Worksheet
    Dim wsClt As Worksheet
    Dim dt As Date
    Dim lngToGyo As Long
     
    lngGyoMx = Range("B" & Rows.Count).End(xlUp).Row
    For lngGyo = 2 To lngGyoMx
        Set wsMa = Worksheets("main")
        If strCltName <> wsMa.Range("B" & lngGyo).Value Then
            If lngGyo <> 2 Then
                DrawKeisen
            End If
            strCltName = wsMa.Range("B" & lngGyo).Value
            Set wsMa1 = Worksheets("main1")
            wsMa1.Copy after:=Worksheets(Worksheets.Count)
            Set wsClt = ActiveSheet
            wsClt.Name = strCltName
            lngToGyo = 16
        End If
        wsClt.Range("H" & lngToGyo).Value = wsMa.Range("F" & lngGyo).Value
        wsClt.Range("E" & lngToGyo).Value = wsMa.Range("D" & lngGyo).Value
        wsClt.Range("F" & lngToGyo).Value = wsMa.Range("E" & lngGyo).Value
        If wsMa.Range("G" & lngGyo).Value > 0 Then
            wsClt.Range("I" & lngToGyo).Value = wsMa.Range("G" & lngGyo).Value
        Else
            wsClt.Range("J" & lngToGyo).Value = wsMa.Range("G" & lngGyo).Value
        End If
        dt = wsMa.Range("C" & lngGyo).Value
        wsClt.Range("B" & lngToGyo).Value = Right(Year(dt), 2)
        wsClt.Range("C" & lngToGyo).Value = Month(dt)
        wsClt.Range("D" & lngToGyo).Value = Day(dt)
        If lngToGyo = 16 Then
            wsClt.Range("K" & lngToGyo).Value = wsMa.Range("G" & lngGyo).Value
        Else
            wsClt.Range("K" & lngToGyo).Value = wsMa.Range("G" & lngGyo).Value + wsClt.Range("K" & lngToGyo - 1).Value
        End If
        lngToGyo = lngToGyo + 1
    Next
    DrawKeisen
    wsMa.Activate
End Sub
Public Sub DeleteSheets2()
    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
Private Sub DrawKeisen()
    'シンプルかつキレイです (^^*
    Dim lngGMax As Long
    lngGMax = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lngGMax + 1)
        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 = xlThin
        End With
    End With
End Sub
Private Sub InputNo()
    Dim lngLastGyo As Long
    lngLastGyo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    
    '↓うまいです。
    Worksheets("main").Activate
    Range("A1").Value = "No."
    lngLastGyo = Range("B" & Rows.Count).End(xlUp).Row
    With Range("A2")
        .Value = 1
        .AutoFill Destination:=Range("A2:A" & lngLastGyo), Type:=xlFillSeries
    End With
End Sub
Private Sub SortMainSheet()
    Dim lngLastGyo As Long
    lngLastGyo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    With Worksheets("main").Sort
        With .SortFields
            .Clear
            .Add Key:=Range(sRetsu & "2:" & sRetsu & lngLastGyo), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
        End With
        .SetRange Range("A1:G" & lngLastGyo)
        .Header = xlYes
        .Apply
    End With
End Sub
Private Sub DeleteNum()
    Dim lngLastGyo As Long
    lngLastGyo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    With Worksheets("main")
        .Activate
        .Columns("A").Value = ""
        .Range("A1").Activate
    End With
End Sub
'Private Sub SortMainSheet()
'    With Worksheets("main").Sort.SortFields
'        .Clear
'        .Add Key:=Range("B2:B" & lngLastGyo), _
'            SortOn:=xlSortOnValues, _
'            Order:=xlAscending, _
'            DataOption:=xlSortNormal
'    End With
'    With Worksheets("main").Sort
'        .SetRange Range("A1:G" & lngLastGyo)
'        .Header = xlYes
'        .Apply
'    End With
'End Sub

'Private Sub SortNo()
'    Dim lngLastGyo As Long
'    lngLastGyo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
'    With Worksheets("main").Sort.SortFields
'        .Clear
'        .Add Key:=Range("A2:A" & lngLastGyo), _
'            SortOn:=xlSortOnValues, _
'            Order:=xlAscending, _
'            DataOption:=xlSortNormal
'    End With
'    With Worksheets("main").Sort
'        .SetRange Range("A1:G" & lngLastGyo)
'        .Header = xlYes
'        .Apply
'    End With
'    With Worksheets("main")
'        .Columns("A").Value = ""
'        .Range("A1").Activate
'    End With
'End Sub
'
''SortCltName と SortNo は(ほぼ)並べ替え対象の行が違うだけなので、ひとつにまとめられるかもしれません。
''その場合はモジュールレベル変数を使います。トライしてみてください。
'Private Sub SortCltName()
'    'データ数に関わらず動くように修正しましょう (^^
'    'シンプルかつキレイです (^^*
'    With Worksheets("main").Sort.SortFields
'        .Clear
'        .Add Key:=Range("B2:B" & lngLastGyo), _
'            SortOn:=xlSortOnValues, _
'            Order:=xlAscending, _
'            DataOption:=xlSortNormal
'    End With
'    With Worksheets("main").Sort
'        .SetRange Range("A1:G" & lngLastGyo)
'        .Header = xlYes
'        .Apply
'    End With
'End Sub

hiro さん:

こんにちは。

以下に添削を返送します。参考にしてください。

> コメント欄を拝見し、
> 他の受講生の方のレベルの高さに大変驚いておりますが、
> 伝票作成の宿題を作成致しましたので、
> ご確認の程宜しくお願い致します。

いえいえ。かなりきれいにマクロを書けていると思います。
ひきつづき、学習お楽しみください☆

Option Explicit
Public Sub CreateDenpyo()
    InputNo
    SortCltName
    CalledCreateDenpyo
    SortNo
End Sub
Private Sub CalledCreateDenpyo()
    'ハンガリアン記法で行くなら、「小文字で型、大文字で意味」というスタイルがおすすめです。
    '例: 以下の要領
    'wsMa: ワークシート「main」の意味
    'wsMa1: ワークシート「main1」の意味
    'wsClt: ワークシートのうち、コントロール対象のものという意味
    'strCltName: 文字列のうち、コントロール対象シートの名前という意味
    DeleteSheets
    Dim gyo As Long
    Dim gyoMx As Long
    Dim cltName As String
    Dim maWs As Worksheet
    Dim ma1Ws As Worksheet
    Dim cltWs As Worksheet
    Dim dt As Date
    Dim toGyo As Long
    
    gyoMx = Range("B" & Rows.Count).End(xlUp).Row
    For gyo = 2 To gyoMx
        Set maWs = Worksheets("main")
        If cltName <> maWs.Range("B" & gyo).Value Then
            If gyo <> 2 Then
                DrawKeisen
            End If
            cltName = maWs.Range("B" & gyo).Value
            Set ma1Ws = Worksheets("main1")
            ma1Ws.Copy after:=Worksheets(Worksheets.Count)
            Set cltWs = ActiveSheet
            cltWs.Name = cltName
            toGyo = 16
        End If
        cltWs.Range("H" & toGyo).Value = maWs.Range("F" & gyo).Value
        cltWs.Range("E" & toGyo).Value = maWs.Range("D" & gyo).Value
        cltWs.Range("F" & toGyo).Value = maWs.Range("E" & gyo).Value
        If maWs.Range("G" & gyo).Value > 0 Then
            cltWs.Range("I" & toGyo).Value = maWs.Range("G" & gyo).Value
        Else
            cltWs.Range("J" & toGyo).Value = maWs.Range("G" & gyo).Value
        End If
        dt = maWs.Range("C" & gyo).Value
        cltWs.Range("B" & toGyo).Value = Right(Year(dt), 2)
        cltWs.Range("C" & toGyo).Value = Month(dt)
        cltWs.Range("D" & toGyo).Value = Day(dt)
        If toGyo = 16 Then
            cltWs.Range("K" & toGyo).Value = maWs.Range("G" & gyo).Value
        Else
            cltWs.Range("K" & toGyo).Value = maWs.Range("G" & gyo).Value + cltWs.Range("K" & toGyo - 1).Value
        End If
        toGyo = toGyo + 1
    Next
    DrawKeisen
    maWs.Activate
End Sub
Public Sub DeleteSheets()
    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
Private Sub DrawKeisen()
    'シンプルかつキレイです (^^*
    Dim gMax As Long
    gMax = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & gMax + 1)
        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 = xlThin
        End With
    End With
End Sub
Private Sub InputNo()
    'autofillを使った書き方も研究してみてください。自動記録しつつautofillして得られたマクロを修正して作ると比較的簡単かと。
    Dim c As Long
    Dim lastGyo As Long
    Worksheets("main").Activate
    Range("A1").Value = "No."
    lastGyo = Range("B" & Rows.Count).End(xlUp).Row
    For c = 2 To lastGyo
        Range("A" & c).Value = c - 1
    Next
End Sub

'SortCltName と SortNo は(ほぼ)並べ替え対象の行が違うだけなので、ひとつにまとめられるかもしれません。
'その場合はモジュールレベル変数を使います。トライしてみてください。
Private Sub SortCltName()
    'データ数に関わらず動くように修正しましょう (^^
    'シンプルかつキレイです (^^*
    With Worksheets("main").Sort.SortFields
        .Clear
        .Add Key:=Range("B2:B317"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
    End With
    With Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
End Sub
Private Sub SortNo()
    'データ数に関わらず動くように修正しましょう (^^
    'シンプルかつキレイです (^^*
    With Worksheets("main").Sort.SortFields
        .Clear
        .Add Key:=Range("A2:A317"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal
    End With
    With Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
    With Worksheets("main")
        .Columns("A").Value = ""
        .Range("A1").Activate
    End With
End Sub

受講生 さん:

おはようございます。

添削を返送します。

> ①worksheet("main")A列に番号を割り振るマクロにてオートフィルを活用しコードを記述してみました。
> 使い方としてはこのような感じであっておりますでしょうか？

良いかと思います。
他の方のコードも参考にしてみてください。このウェブページ内を autofill というキーワードで検索するといろいろ出てきます。

> ②withの中身について並び替えマクロ（sorting)も自分なりに改編してみました。一応動きました。
> select/selectionについては基本まとめる、というお話がありましたが、その上で同じオブジェクトやプロパティ、メソッドを連続して指定しているコードがあればwitでまとめる、みたいな考え方で正しいでしょうか？

基本の考え方は、「オブジェクトを指定している部分が重複しているなら with でまとめ得る」です。この表現で必要十分です。
「プロパティ、メソッドも with でまとめ得る」というのはちょっと違います。
たとえば、上位のオブジェクトから見たらそのオブジェクトのプロパティと見えるものがあったとしても、その「上位のオブジェクトから見たらプロパティ」なもの自身が「オブジェクト」であれば with で指定するオブジェクト足り得ます。メソッドも、その戻り値(*発展編2で出てくる用語。ざっくり言うと、その言葉か指すもの)がオブジェクトならば with でまとめ得ます。

たとえば、 workbooks("book1.xlsm").worksheets("sheet1").range("a1").value = 3 というコードがあったとして、

workbooks("book1.xlsm") はオブジェクトです。
worksheets("sheet1") は workbooks("book1.xlsm") から見ればプロパティですが、 worksheets("sheet1") 自身はオブジェクトです。
range("a1") は worksheets("sheet1") から見ればプロパティですが、 range("a1") 自身はオブジェクトです。

よって、以下のどの書き方も可能です。

with workbooks("book1.xlsm")
   ' ...
   ' ...
   ' ...
end with
with workbooks("book1.xlsm").worksheets("sheet1")
   ' ...
   ' ...
   ' ...
end with
with workbooks("book1.xlsm").worksheets("sheet1").range("a1")
   ' ...
   ' ...
   ' ...
end with

もう少し具体的な例を示します。
たとえば、以下の with_sample_before のようなコードがあったとして with_sample_after1, with_sample_after2, with_sample_after3 のどの手直しの仕方もありです。
.Range("a1") だけでなく、 .Font, .CurrentRegion のどれも、戻り値はオブジェクトです。ですので以下のどれもOKです。(前者は戻り値として Font オブジェクトを返し、後者は戻り値として Range オブジェクトを返す)

なお、念のために補足すると、「(withを使わない書き方も含めて)以下のうちどれかだけが正解/最適化された状態であり、どれかだけができるようになっていれば良い」というものではありません。
どのオブジェクトについてまとめた表現にするか？どこまでやるべきか？というのはケースバイケースです。

「ケースバイケース」なので、どの書き方も自在にできるようになるまで練習する必要があります。
「自分の技術的な限界のためにこのやり方しか選択できない」となるとコーディングに不自由が生じてしまうからです。

Sub Initialize()
    '事前準備
    Worksheets("sheet1").Range("a1").CurrentRegion.Clear
    Worksheets("sheet1").Range("e1").Clear
    
    Worksheets("sheet1").Range("a1").Value = "no"
    Worksheets("sheet1").Range("b1").Value = "会社名"
    Worksheets("sheet1").Range("c1").Value = "担当者名"
    
    Dim c As Long
    For c = 2 To 11
        Worksheets("sheet1").Range("a" & c).Value = c - 1
        Worksheets("sheet1").Range("b" & c).Value = "会社" & c - 1
        Worksheets("sheet1").Range("c" & c).Value = "担当者名" & c - 1
    Next
End Sub
Sub with_sample_before()
    Initialize
    
    '以下を with を使ってリライトしてみましょう
    Worksheets("sheet1").Range("a1").Value = "番号"
    Worksheets("sheet1").Range("a1").Font.Color = vbBlue
    Worksheets("sheet1").Range("a1").Font.Size = 12
    Worksheets("sheet1").Range("a1").CurrentRegion.Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
    Worksheets("sheet1").Range("e1").Value = Worksheets("sheet1").Range("a1").CurrentRegion.Count
End Sub

Sub with_sample_after1()
    Initialize
    
    'リライト例1
    With Worksheets("sheet1")
        .Range("a1").Value = "番号"
        .Range("a1").Font.Color = vbBlue
        .Range("a1").Font.Size = 12
        .Range("a1").CurrentRegion.Sort Key1:=.Range("A1"), Order1:=xlDescending, Header:=xlYes
        .Range("e1").Value = .Range("a1").CurrentRegion.Count
    End With
End Sub

Sub with_sample_after2()
    Initialize
    
    'リライト例2
    With Worksheets("sheet1").Range("a1")
        .Value = "番号"
        .Font.Color = vbBlue
        .Font.Size = 12
        .CurrentRegion.Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
        Worksheets("sheet1").Range("e1").Value = .CurrentRegion.Count
    End With
End Sub

Sub with_sample_after3()
    Initialize
    
    'リライト例3
    With Worksheets("sheet1").Range("a1")
        .Value = "番号"
        With .Font
            .Color = vbBlue
            .Size = 12
        End With
        With .CurrentRegion
            .Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
            Worksheets("sheet1").Range("e1").Value = .Count
        End With
    End With
End Sub

添削内でも、修正過程を含めて示しました。
実際に同様の過程を経てやってみてください。

> ③ご指摘いただいている中で「'以下の3つ、format関数を適用することも試してみてください」の部分だけ、アドバイス頂いた内容が理解できませんでした・・・浅識で申し訳ございません・・・。

添削を参照してください。
また、添削を参考にして Format 関数についてご自身で研究してみてください。ネットを検索すると、サンプルがいろいろ転がっています。

> ④サブプロシージャ：keisenの中身を頂いたアドバイス通りに添削してみました（というかほぼ頂いたもののコピペですが・・・）
> すると各シートの罫線が記載されなくなってしまったのですが、何か必要部分を消してしまっているのでしょうか・・・？

以下のとおりなので、左辺と上辺にはきちんと罫線が引かれています。(上辺はもともとある15行目の下辺にある線とかぶるので見た目上変化はないですが)
ということで、あとは、底辺、右辺、内部の縦線、内部の横線ですね。

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 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

以下は添削です。

Dim G_retu As String
Public Sub main()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    sheetDelete
    
    writeNo
    
    G_retu = "B"
    sorting
    
    sheetcreat


    G_retu = "A"
    sorting
    
    Aclear
    Worksheets("main").Select
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Public Sub sheetDelete()
    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 writeNo()
    Dim lnMx As Long
'    lnMx = Worksheets("main").Range("B" & Worksheets("main").Rows.Count).End(xlUp).Row
    With Worksheets("main")
        lnMx = .Range("B" & .Rows.Count).End(xlUp).Row '右辺にくるオブジェクトもwithで表現できる
        .Range("A2").Value = 1
        .Range("A3").Value = 2
'        .Range("A2:A3").AutoFill Destination:=Range("A2:A" & lnMx), Type:=xlFillDefault
        .Range("A2:A3").AutoFill Destination:=.Range("A2:A" & lnMx), Type:=xlFillDefault 'Destinationのセル指定で先頭の「 . 」が抜けています
    End With
    
End Sub
    
    
Private Sub sorting_tensau0() '添削前の状態
    Dim lnMx As Long
    lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    With Worksheets("main")
        .Select
        .Range(G_retu & "1").Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Worksheets("main").Range(G_retu & "1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
Private Sub sorting_tensaku1()
    Dim lnMx As Long
    lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    With Worksheets("main")
        .Select
        .Range(G_retu & "1").Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 _
            Key:=Worksheets("main").Range(G_retu & "1"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal '事前準備。可読性向上のために改行を増やした。
        With .Sort
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
Private Sub sorting_tensaku2()
    Dim lnMx As Long
    With Worksheets("main")
        lnMx = .Range("B" & Rows.Count).End(xlUp).Row
'        .Select
'        .Range(G_retu & "1").Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 _
            Key:=.Range(G_retu & "1"), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortNormal 'key1:= で Worksheets("main"). を . に変更
        With .Sort
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
Private Sub sorting_tensaku3()
    Dim lnMx As Long
    With Worksheets("main")
        lnMx = .Range("B" & Rows.Count).End(xlUp).Row
        With .Sort '.sort でまとめてみる
            .SortFields.Clear
            .SortFields.Add2 _
                Key:=Worksheets("main").Range(G_retu & "1"), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal 'key1:= で Worksheets("main"). は復活させざるを得ない。(.Sort内だから)
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
Private Sub sorting_tensaku4()
    Dim lnMx As Long
    With Worksheets("main")
        lnMx = .Range("B" & Rows.Count).End(xlUp).Row
        With .Sort
            With .SortFields '.sortfields でまとめてみる
                .Clear
                .Add2 _
                    Key:=Worksheets("main").Range(G_retu & "1"), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlAscending, _
                    DataOption:=xlSortNormal
            End With
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub
Private Sub sorting()
    Dim lnMx As Long
    With Worksheets("main")
        lnMx = .Range("B" & Rows.Count).End(xlUp).Row
        With .Sort
            With .SortFields '.sortfields でまとめてみる
                .Clear
                .Add2 _
                    Key:=Worksheets("main").Range(G_retu & "1"), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlAscending, _
                    DataOption:=xlSortNormal
            End With
            .SetRange Worksheets("main").Range("A2:G" & lnMx)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub


Private Sub sheetcreat()
    Dim shFm As Worksheet
    Dim shTo As Worksheet
    
    Dim lnFm As Long
    Dim lnFmMx As Long
    
    Dim lnTo As Long
    
    Dim strName As String
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If strName <> shFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                keisen
            End If
            strName = shFm.Range("B" & lnFm).Value
            Debug.Print strName
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = strName
            lnTo = 16
        End If
        dt = shFm.Range("C" & lnFm).Value
        shTo.Range("B" & lnTo).Value = Format(dt, "yy") 'Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Format(dt, "mm") 'Month(dt)
        shTo.Range("D" & lnTo).Value = Format(dt, "dd") '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
        
        Select Case shFm.Range("G" & lnFm).Value
            Case Is > 0
                shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
            Case Else
                shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
        End Select
        If lnTo = 16 Then
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
        Else
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
        End If
        
        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)
        .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
    End With
End Sub

Private Sub Aclear()
    Dim lnMx
    lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
    Debug.Print lnMx
    Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub

受講生 さん:

こんばんは。

添削を返送します。
全体に、とてもしっかり書けていると感じます。
With ... End With の中身の整理は今回お送りした添削内容を元に練習してみてください。

次回添削課題を拝見するのを楽しみにしています。

Option Explicit

Dim G_retu As String
Public Sub main()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    sheetDelete
    
    writeNo
    
    G_retu = "B"
    sorting
    
    sheetcreat

    G_retu = "A"
    'シート「main」の表は、実行前の順序に戻りますでしょうか。僕の環境では戻りませんでした。この書き方だとたぶん戻らないはずです。
'    Worksheets("main").Select '←これがあれば確実に元に戻る。でなければ？(*1)を参照してください。
    sorting
    
    Aclear
    Worksheets("main").Select
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Public Sub sheetDelete()
    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 writeNo()
    Dim ws As Worksheet
    Dim lnFmMx As Long
    Dim ln As Long
    
    'autofillを使う方法も研究してみてください。
    Set ws = Worksheets("main")
    lnFmMx = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    For ln = 2 To lnFmMx
        ws.Range("A" & ln).Value = ln - 1
    Next
End Sub
    
Private Sub sorting_sample()
    '(*1) アクティブでないシートのセルを指定するのは結構面倒です。
    '並べ替えは、慣れないうちは、並べ替え対象のシートをアクティブにしてからのほうがそういう意味でよいです。
    'いただいたマクロで、シートの指定がない箇所を明示してみました
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row 'セルの前に、worksheetの指定が抜けている
    Range(G_retu & "1").Select 'セルの前に、worksheetの指定が抜けている
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Range(G_retu & "1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'Key:=Range(G_retu & "1")で、セルの前に、worksheetの指定が抜けている(抜けていても実務上はいちおうOKなようだが)
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A2:G" & lnMx) 'セルの前に、worksheetの指定が抜けている(抜けていても実務上はいちおうOKなようだが)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Private Sub sorting()
    'このプロシージャの中身に最適化については、 sorting_sample に記載したこと、keisen_sample に記載したことを研究の上、再トライしてみてください。
    '次回課題提出いただいたときに整理してお伝えしたいと思います。
    Dim lnMx As Long
    lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
'    Worksheets("main").Range(G_retu & "1").Select '不要
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Worksheets("main").Range(G_retu & "1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Worksheets("main").Range("A2:G" & lnMx)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Private Sub sheetcreat()
    Dim shFm As Worksheet
    Dim shTo As Worksheet
    
    Dim lnFm As Long
    Dim lnFmMx As Long
    
    Dim lnTo As Long
    
    Dim strName As String
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If strName <> shFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                keisen
            End If
            strName = shFm.Range("B" & lnFm).Value
            Debug.Print strName
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = strName
            lnTo = 16
        End If
        dt = shFm.Range("C" & lnFm).Value
        '以下の3つ、format関数を適用することも試してみてください
        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
        
        Select Case shFm.Range("G" & lnFm).Value
            Case Is > 0
                shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
            Case Else
                shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
        End Select
        If lnTo = 16 Then
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
        Else
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
        End If
        
        lnTo = lnTo + 1
    Next
    keisen
End Sub

Private Sub keisen_sample()
    '以下の要領で
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx)
        .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
    End With
End Sub
Private Sub keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    Range("B16:K" & lnMx).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

Private Sub Aclear()
    Dim lnMx
    lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
    Debug.Print lnMx
    Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub

受講生 さん:

モジュールは大きく分けて順に以下の3つの領域に分けられます。
(各領域の名称は、かなり思い切って大胆に言い切っています)

[1] Option宣言領域
[2] モジュールレベル変数、定数宣言領域
[3] プロシージャ領域

領域 [2] では、変数の宣言はできますが、変数への値の格納等はできません。
変数への値の格納等は、領域 [3] に記述したプロシージャ内で行います。

Option Explicit

Dim saidai As Long
'saidai = Range("A" & Rows.Count).End(xlUp).Row 'NG

Sub hoge()
    saidai = Range("A" & Rows.Count).End(xlUp).Row 'OK
End Sub

値の設定は、その値を利用するタイミングより前であればどこでも良いです。
とはいえ、見通しのよいところで行うのが良いでしょう。
たとえば、以下では、値の設定は、OKのところで行うほうが、procedure1の中で行うよりメンテナンスが楽です。

Option Explicit

Dim saidai As Long

Sub hoge()
    saidai = Range("A" & Rows.Count).End(xlUp).Row 'OK
    procedure1
    procedure2
    procedure3
    procedure4
End Sub

Sub procedure1()
    'saidai = Range("A" & Rows.Count).End(xlUp).Row 'NGということはないが好ましくない
    '変数 saidai を使う処理...
End Sub
Sub procedure2()
    '変数 saidai を使う処理...
End Sub
Sub procedure3()
    '変数 saidai を使う処理...
End Sub
Sub procedure4()
    '変数 saidai を使う処理...
End Sub

ひきつづき、マクロ、楽しんでください (^^

こんにちは。添削返送します。
Publicキーワードの活用以外の部分についてはとてもよく書けています。

>作成中はsubプロシージャごと変数へ格納しなければならないので、ちょっとめんどくさいなと感じました

おっしゃりたいことがよくわかりませんでした。
以下を参考に、Public, Private キーワードの機能と目的をご理解のうえ、もし質問があれば改めてご質問いただければと思います。

Option Explicit
'モジュールレベル変数はデフォルトprivate (Dim hoge で、 Private hoge と書いたときと同じ意味)
'プロシージャはデフォルトpublic

'モジュールレベル変数をpublicにするのは、他のモジュールからも呼び出したいときです
'プロシージャをprivateにするのは、他のモジュールから呼び出されたくないときです
Public shFm As Worksheet 'Privateにします。他のモジュールから呼び出したいわけではないので
Public shTo As Worksheet 'Privateにします。他のモジュールから呼び出したいわけではないので
Public lnFmMx As Long    'Privateにします。他のモジュールから呼び出したいわけではないので
Sub zikkou() 'Publicにします。実行ボタンを押したときに呼び出されるようにしたいものなので
    Set shFm = Worksheets("main")
    lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    sakuzyo
    bango
    narabikae
    sakusei
    'あとはここで元の表を並べ替えるかどうか ogawa
End Sub


Sub bango() 'Privateにします。 zikkou からのみ呼び出されるので
'autofillを使った書き方も研究してみましょう！ ogawa
'    Set shFm = Worksheets("main")
'    lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    
    Dim lnFm As Long
    
    shFm.Range("A1").Value = "No."
    For lnFm = 2 To lnFmMx
        shFm.Range("A" & lnFm).Value = lnFm - 1
    Next
End Sub

Sub narabikae() 'Privateにします。 zikkou からのみ呼び出されるので
'    Set shFm = Worksheets("main")
'    lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    
    'shFm.Sort や shFm.SOrt.SOftFields で with を使ってまとめてみましょう ogawa
    shFm.Sort.SortFields.Clear
    shFm.Sort.SortFields.Add2 _
        Key:=Range("B2:B" & lnFmMx), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With shFm.Sort
        .SetRange Range("A1:G" & lnFmMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    shFm.Range("A1").Select
End Sub

Sub sakusei() 'Privateにします。 zikkou からのみ呼び出されるので
'    Set shFm = Worksheets("main")
'    lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    
    Dim lnTo As Long
    Dim lnFm As Long
    Dim st As String
    Dim dt As Date
    
    For lnFm = 2 To lnFmMx
        If shFm.Range("B" & lnFm).Value <> shFm.Range("B" & lnFm - 1).Value Then
            If lnFm <> 2 Then
                koushisen
            End If
            st = shFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
            lnTo = 16
            
        End If
        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
        If lnTo = 16 Then
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
        Else
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1).Value
        End If
        '↓あえてここに置いたのですか。おもしろいですね。 Format関数を使った書き方を研究してみてください ogawa
        dt = shFm.Range("C" & lnFm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(Date)
        shTo.Range("D" & lnTo).Value = Day(dt)
        lnTo = lnTo + 1
    Next
    koushisen
End Sub
Sub koushisen() 'Privateにします。 sakusei からのみ呼び出されるので
    'Set shTo = Worksheets("?{??@??")
    Dim lnToMx As Long
    lnToMx = shTo.Range("B" & Rows.Count).End(xlUp).Row
    With shTo.Range("B16:K" & lnToMx + 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 = xlThin
        End With
    End With

End Sub
Sub sakuzyo() 'Publicにします。削除ボタンを押したときに呼び出されるようにしたいものなので
    Dim sh As Worksheet
    
    Application.DisplayAlerts = False
    
    For Each sh In Worksheets
        If Left(sh.Name, 4) <> "main" Then
            sh.Delete
        End If
    Next
    Application.DisplayAlerts = True

End Sub

受講生 さん:

お楽しみください☆

> 小川様
>
> 添削ありがとうございます。
> 別回答まで頂けて非常に勉強になります。
> また、モチベーションも上がりました。
>
> しっかりと見直して自分のものにしたいと思います。
> お忙しいところ本当にありがとうございました。
> 引き続き、精進していきます。
>

受講生 さん:

こんにちは。

宿題、拝見しました。

とても良く書けていると思います。
これなら、実務でも楽しんでガンガンとマクロを書けているのではないかと思いますが、いかがでしょうか。

添削を返送します。
まずは添削を。そのあと、ところどころについてのリライト提案などです。

Option Explicit
'**************************************************************************************
'まず機能を分けよう
'[1]データをソートする機能
'※まずはAにNOを割り振る
'①取引先名称を名前順にする
'②その後､NOに置き換える
'[2] 取引先名称が変わるまで転記する処理を続ける
'①上の名前が違ったときは
'    新しいワークシートを作成
'    転記先のシートに情報を転記する
'    新しいシートにその行の情報を転記する
'    そしてループでまた判定に戻る
'② 上の名前と同じだったときは
'    新しいワークシートをつくる処理に移らずに
'    転記する処理を繰り返す
'
'[3] 転記を終えたら､最後に線を描く処理を行う
'    ※はじめの処理は行わない
'    [2] の①の最初に前のシートのところで
'    線を描く処理をはさむ
'    その後に新しいワークシートの処理へ進む
'
'[4] そして最後にボタンを作成して終了
'**************************************************************************************
'まとめ
Sub Main() '最初に確認です。伝票作成ボタンを押すと怒られませんか？僕は怒られました。モジュール名main、プロシージャ名mainでかぶっているからではないか？と。 ogawa
    '↓分かりやすいですね！ ogawa
    Call NoTuika
    Call Sort_Name
    Call Make_Ws
    Call Sort_No
End Sub
'**************************************************************************************
'シートの削除
'**************************************************************************************
Sub Delete_Sheet() '↑コメント秀逸です。（他も同様） ogawa
    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 Make_Ws()
    Call Delete_Sheet
'**************************************************
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Set wsFm = Worksheets("main")
    Dim cnt As Long
    Dim cGyo As Long
    Dim cLas As Long: cLas = wsFm.Range("B" & Rows.Count).End(xlUp).Row '←宣言と値設定を1行で済ませるアイデア、おもしろいです！ ogawa
'**************************************************
    For cnt = 2 To cLas
        '新しいシートを作成する処理↓
        If wsFm.Range("B" & cnt).Value <> wsFm.Range("B" & cnt - 1).Value Then
            '次の行への処理へ移る前に前のシートに線を描いていく
            If cnt > 2 Then
                Call Make_Line
            End If
            
            'ワークシートをさくせいして
            Sheets("main1").Copy , after:=Worksheets("main") '途中のカンマは不要(結果的に動きますが) ogawa
            Set wsTo = ActiveSheet
            wsTo.Name = wsFm.Range("B" & cnt).Value
            wsTo.Range("F2").Value = wsTo.Name
            '転記先の行数をリセット
            cGyo = 16
        End If
        '新しいシート作成後、転記する処理↓
            '作成済みのワークシートに転記
            '↓[1] [2]までインデントひとつ多すぎでした (^^; ogawa
            '取引内容
            wsTo.Range("H" & cGyo).Value = wsFm.Range("F" & cnt).Value
            '会計番号
            wsTo.Range("E" & cGyo).Value = wsFm.Range("D" & cnt).Value
            '伝票番号
            wsTo.Range("F" & cGyo).Value = wsFm.Range("E" & cnt).Value
            
            '取引金額の分岐
            If wsFm.Range("G" & cnt).Value > 0 Then
                '借方金額
                wsTo.Range("I" & cGyo).Value = wsFm.Range("G" & cnt).Value
            Else
                '貸方金額
                wsTo.Range("J" & cGyo).Value = wsFm.Range("G" & cnt).Value
            End If
            
            '日付記入
            Dim dt As Date: dt = wsFm.Range("C" & cGyo).Value 'この変数定義はForループに入るより前でしましょう ogawa
            '年
            wsTo.Range("B" & cGyo).Value = Right(Year(dt), 2)
            '月
            wsTo.Range("C" & cGyo).Value = Month(dt)
            '年
            wsTo.Range("D" & cGyo).Value = Day(dt)
            'K列に入れる「残高」が...(^^; ogawa
            '次の転記行を定数として足す
            cGyo = cGyo + 1
    Next '[2]この手前までインデントひとつ多すぎでした (^^; ogawa
    '最後のシートにも線を描く処理を施す
    Call Make_Line

End Sub

'**************************************************************************************
'線を書く処理
'**************************************************************************************
Sub Make_Line() '↓withの使い方、とてもよくできています (^^* ogawa
    Dim Aws As Worksheet: Set Aws = ActiveSheet
    Dim cLas As Long: cLas = Aws.Range("H" & Rows.Count).End(xlUp).Row
    With Aws.Range("B16:K" & cLas + 1)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
        End With
    End With
    
End Sub
'**************************************************************************************
'データの順序を処理
'**************************************************************************************
Sub NoTuika()

    Dim cGyo As Long
    Dim cLas As Long
    Dim wsFm As Worksheet: Set wsFm = Worksheets("main")
    cLas = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    
    Dim c As Long '↓autofillを使う値投入方法も研究してみてください！ ogawa
    wsFm.Range("A1").Value = "No."
    For c = 2 To cLas
        Range("A" & c).Value = c - 1
    Next
    
        
End Sub

Sub Sort_Name()
     'データ件数が316件でない場合も動くマクロになるように修正しましょう ogawa
     ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
     ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("B2:B317"), _
         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With

End Sub

Sub Sort_No()
     'データ件数が316件でない場合も動くマクロになるように修正しましょう ogawa
     ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
     ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("A2:A317"), _
         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With

End Sub
'**************************************************************************************

以下は別解等です。

Option Explicit
'小川別解をところどころ入れます
Sub Main_ogawa()
    '画面の更新を止める(20%程度高速化すると言われています)。ありとなしとでのパフォーマンスを比較してみてください。
    Application.ScreenUpdating = False
    Call NoTuika_ogawa
    Call Sort_Name_ogawa
    Call Make_Ws_ogawa
    Call Sort_No_ogawa
    Application.ScreenUpdating = True
End Sub
Sub Delete_Sheet_ogawa()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Not Left(ws.Name, 4) = "main" Then 'notで書いてみた
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub Make_Ws_ogawa()
    Call Delete_Sheet_ogawa
    
    Dim wsFm As Worksheet: Set wsFm = Worksheets("main") '1行にまとめる
    Dim wsTo As Worksheet
    Dim cnt As Long
    Dim cGyo As Long
    Dim cLas As Long: cLas = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim dt As Date 'ここでなくループの中で変数宣言すると、ループの回数だけ変数を宣言しなおすことになります。非効率 ogawa
    For cnt = 2 To cLas
        If wsFm.Range("B" & cnt).Value <> wsFm.Range("B" & cnt - 1).Value Then
            If cnt > 2 Then
                Call Make_Line_ogawa
            End If
            Sheets("main1").Copy after:=wsFm 'シートの指定の書き方を変更
            Set wsTo = ActiveSheet
            wsTo.Name = wsFm.Range("B" & cnt).Value
            wsTo.Range("F2").Value = wsTo.Name
            cGyo = 16
        End If
        With wsTo 'withでまとめてみた
            .Range("H" & cGyo).Value = wsFm.Range("F" & cnt).Value
            .Range("E" & cGyo).Value = wsFm.Range("D" & cnt).Value
            .Range("F" & cGyo).Value = wsFm.Range("E" & cnt).Value
            If wsFm.Range("G" & cnt).Value > 0 Then
                .Range("I" & cGyo).Value = wsFm.Range("G" & cnt).Value
            Else
                .Range("J" & cGyo).Value = wsFm.Range("G" & cnt).Value
            End If
            'K列への入力、やってみましょう！
            dt = wsFm.Range("C" & cGyo).Value
            .Range("B" & cGyo).Value = Format(dt, "yy") 'Format関数
            .Range("C" & cGyo).Value = Format(dt, "mm") 'Format関数
            .Range("D" & cGyo).Value = Format(dt, "dd") 'Format関数
        End With
        cGyo = cGyo + 1
    Next
    Call Make_Line_ogawa
End Sub

Sub Make_Line_ogawa()
    Dim Aws As Worksheet: Set Aws = ActiveSheet
    Dim cLas As Long: cLas = Aws.Range("H" & Rows.Count).End(xlUp).Row
    With Aws.Range("B16:K" & cLas + 1)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous 'それぞれwith内で1度しか登場しなかったので、withブロックは解除
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    
End Sub
Sub NoTuika_ogawa()

    Dim wsFm As Worksheet: Set wsFm = Worksheets("main")
    Dim cGyo As Long
    Dim cLas As Long: cLas = wsFm.Range("B" & Rows.Count).End(xlUp).Row 'この順序ならここもこのタイミングで１行で書ける
    
    Dim c As Long
    wsFm.Range("A1").Value = "No."
    For c = 2 To cLas
        Range("A" & c).Value = c - 1
    Next
End Sub

'↓sort_name, sort_no はkeyになる列が異なるだけ。
'  なので、１つのプロシージャだけで、モジュールレベル変数を使って使い回せるようにも書けます。
'  (発展編2レベルのノウハウを使うなら、モジュールレベル変数ではなく、引数つきプロシージャで)
'  あとは、 Range("A1:G317") の代わりに currentregion を使うとか。(ワークシートを適切に指定しないとバグりますが)
Sub Sort_Name_ogawa()
    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

Sub Sort_No_ogawa()
    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

> 小川様
>
> お世話になっております。KSです。
>
> 宿題を作成してみました。
> お時間があるときに見ていただけると幸いです。
> 引き続き、メールセミナーに取り組んでいきます。

受講生 さん:

改めて、こちらでも添削を公開します。

大変よく書けています。
これなら、どこでも何でも、今までに習ったスキルでできることならば、たいていのことはできるでしょう (^^

Option Explicit

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 number()
    '↓autofillを使う方法も検討してみてください。
    Dim n As Long
    For n = 2 To Range("B65536").End(xlUp).Row
        Range("A" & n).Value = n - 1
    Next
    '↓end sub の位置がズレていますね (^^;
    End Sub

Sub narabe1()
    '↓よく書けています (^^
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Sub narabe2()
    '↓narabe1と共通要素多いので、モジュールレベル変数を使って narabe1, narabe2 を
    '  共通化してもいいかもですね。次回の課題ではそこまで取り組まれてみては？とも。
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("A2:A317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Sub denpyo()
    '↓変数名等、とてもよいです (^^
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Dim moto As Long
    Dim saki As Long
    Dim mx As Long
    
    Set wFm = Worksheets("main")
    wsdelete '「WsDelete」等、語彙の先頭を大文字にしてメリハリをつけた書き方にするのもあり
    wFm.Activate
    number '英単語一文字のプロシージャ名はあまりよろしくないかと。思わぬところでvbaデフォルトのキーワードと重複する可能性があります。
    narabe1
    
    
    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
                '[1]
                '別プロシージャにせず、ここに入れたのですね。それもよいかと思います。
                'とてもきちんと書けていますよ！
                'あえて言うなら、[2]とのコードの重複が多いので、そこを嫌うなら別プロシージャに。
                'そのほうが、メンテナンスは楽になります。
                '*修正が発生するにしても、直すのは一箇所でいいから
                '*コードの行数が減って、見通しがよくなるから
                '*[1],[2]で同じ処理をしていると、可読性高く分かるようになるから
                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 If
        
            saki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & moto).Value
            
            '空白、二行はいらないかな...。
        End If
        'wFm.Range("C" & moto).Valueが3回登場するし、いったん変数に入れてから以下の3行の処理をする、というのもありかと
        wTo.Range("B" & saki).Value = Left(Year(wFm.Range("C" & moto).Value), 2)
        wTo.Range("C" & saki).Value = Month(wFm.Range("C" & moto).Value)
        wTo.Range("D" & saki).Value = Day(wFm.Range("C" & moto).Value)
        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]
    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
    
    narabe2
    '最後に シート「mail」をactivateしてもよいかも。
End Sub

[補足]
シートに貼り付ける押下用ボタンは、「オブジェクト名」を変更可能です。
以下の手順
[1]デサインモードにする
[2]ボタンを右クリック
[3]右クリックメニューからプロパティを選択
[4]「プロパティ」のサブウィンドウが表示される
[5]「プロパティ」のサブウィンドウから、「オブジェクト名」を編集

なお、オブジェクト名を変更したら、ボタンを押したときに実行されるプロシージャは、再度作成する必要があります

受講生 さん:

ActiveSheet.PrintPreview

がいらないんじゃないかな、と思います。
ここで、プレビューが表示されます。

２箇所ある、以下も不要ですね。
Application.PrintCommunication = True

というか、不要なものまだまだあるはずなので、発展編１の第３章「自動記録」で習ったように、極限までもっと不要そうなコードを削ってみてください！


> 伝票印刷（1ページ全部入る）印刷出来る時と出来ない時があり困っています。
> 長い伝票は出来ます。
> .FitToPagesWide = 390　←プリンターが毎回10-400の入力を求めて来ます。
> エクセル操作では問題無く（1ページ全部入る）印刷が出来ます。

A.Sさん:

よかったです。

講座で学ぶ
↓
演習を解いてみる
↓
再度講座を見直す
↓
リトライする

というステップは、プログラミング言語習得でとても大切です。
というか、ここがしっかりできるならば、僕はあまり必要ではありませんw

特に、一度書いてみてから見本の流れを再確認するのが大事です。
すると、以前には見えなかったレベルで細かいところまで目が行くようになると同時に、全体を俯瞰する目も養われます。




> 小川先生
>
> コメントありがとうございます。
> 見本に沿って書いてみてから再度最初から何も見ないで
> 書こうとしたところ、不思議と何処から手を付ければ良いのか
> 頭の中でイメージが出来ましたので、殆ど迷うことなく
> 書き上げることが出来ました。
>
> これもひとえに小川先生のご教示があったからこそと
> 大変感謝の気持ちで一杯です。
> 現在、発展編1を受講中ですので、更にレベルを上げられるように
> 精進して参りたいと思います。
> 今後とも、ご指導の程、よろしくお願い致します。

A.Sさん:

拝見しました。

完璧に近いと思います。

ご自身の感触としてはどうでしょうか。



> 小川先生
>
> お忙しい中、添削誠にありがとうございます。
> ご教示いただきましたとおり、見本に沿って書くということを2回行った後に、最初からマクロを書き直しました。
> 再度、恐れ入りますが、添削の程、どうぞよろしくお願い致します。
>
>

Public Sub CreateDenpyo()
>     DeleteSheets
>     Numbering
>     Narabekae_Torihikisaki
>     Denpyosheet_Set
>     Narabekae_No
> 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」シートのB列を昇順に並び替えるマクロ
> Private Sub Narabekae_Torihikisaki()
>     With Worksheets("main").Sort.SortFields
>         .Clear
>         .Add Key:=Range("B2:B317"), _
>         SortOn:=xlSortOnValues, _
>         Order:=xlAscending, _
>         DataOption:=xlSortNormal
>     End With
>     With Worksheets("main").Sort
>         .SetRange Range("A1:G317")
>         .Header = xlYes
>         .Apply
>     End With
> End Sub
> 
> '「main」シートのA列を昇順に並び替えるマクロ
> Private Sub Narabekae_No()
>     With Worksheets("main").Sort.SortFields
>         .Clear
>         .Add Key:=Range("A2:A317"), _
>         SortOn:=xlSortOnValues, _
>         Order:=xlAscending, _
>         DataOption:=xlSortNormal
>     End With
>     With Worksheets("main").Sort
>         .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
>     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:=wsFm
>             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 = Right(Year(dt), 2)
>         wsTo.Range("C" & lnTo).Value = Month(dt)
>         wsTo.Range("D" & lnTo).Value = Day(dt)
>         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

A.Sさん:

よくがんばりましたね (^^

全体の構想に問題があります。
見本と比べて再検討してください。

Denpyou_DataSetでお伝えしたとおり、不必要に処理が多いところもありす。
まだこの取引先数 x データ数なのでそれほどのロスではありませんが...。
これだと、「たとえば200件の取引先、3,000件のデータ」だとしたら、級数的に処理にかかる負荷が上がりますね。

と、いろいろ課題があります。

どういう処理のやり方だと、いちばんすっきりするか？
ここまで書ききれたからこそ分かることもあるでしょう。
見本のとおりに書くということをイチから行ってください。
それを2回くらい連続して行うと、すごく力がつくでしょう。

それからまた、イチから書き直してみてください。

Option Explicit
Dim ws As Worksheet '各取引先名シート
Dim wsm As Worksheet '「main」シート
Dim wsm1 As Worksheet '「main1」シート
Dim gyo As Long '「main」シート行変数
Dim gyot As Long '各取引先名シート行変数
Dim blast As Long '「main」シートB列の最後
Dim elast As Long '各取引先名シートE列の最後

'取引先毎の伝票シートを作成するマクロ
Public Sub DenpyouMake()
    'DenpyouSheet_Deleteがすべての作業より前に来るべきです。
    '「初期化」だからです。
    
    'そして、wsmの設定はこのタイミングで。
    'そして、すぐに、 wsm.select してしまいましょう。
    'そのほうがスッキリしたロジックになります。
    
    'つまり...。以下のとおり。そして、wsm, blast はいちいち再計算しない。
    '都度都度算出するなら、その変数は、モジュールレベル変数ではなく、プロシージャ内で宣言するもので。
'    DenpyouSheet_Delete
'    Set wsm = Worksheets("main")
'    wsm.Select
'    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    
    Numbering '「main」シートのA列に番号を振るマクロの呼び出し
    Narabekae_Torihikisaki '「main」シートのB列を昇順に並び替えるマクロの呼び出し
    Denpyou_DataSet '取引先名称シートに伝票データをセットするマクロの呼び出し
    Narabekae_No '「main」シートのA列を昇順に並び替えるマクロ
End Sub


'「main」シートのA列に番号を振るマクロ
Private Sub Numbering()
    Set wsm = Worksheets("main")
    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    Debug.Print "B列の最後="; blast
    
    wsm.Select
    Range("A1").Value = "No."
    For gyo = 2 To blast
        Range("A" & gyo).Value = gyo
    Next
End Sub

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    Set wsm = Worksheets("main")
    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    Debug.Print "B列の最後="; blast

    wsm.Select
    Range("B1").Select
    With wsm.Sort.SortFields
        .Clear
        .Add Key:=Range("B2:B" & blast), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    With wsm.Sort
        .SetRange Range("A1:G" & blast)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    Set wsm = Worksheets("main")
    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    Debug.Print "B列の最後="; blast

    wsm.Select
    Range("A1").Select
    With wsm.Sort.SortFields
        .Clear
        .Add Key:=Range("A2:A" & blast), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    With wsm.Sort
        .SetRange Range("A1:G" & blast)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

'取引先名称シートを作成するマクロ
Private Sub DenpyouSheet_Copy()
    DenpyouSheet_Delete '取引先名称シートを削除するマクロの呼び出し
    Set wsm = Worksheets("main")
    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    Debug.Print "B列の最後="; blast

    For gyo = 2 To blast
        If wsm.Range("B" & gyo).Value <> wsm.Range("B" & gyo + 1).Value Then
            Sheets("main1").Copy After:=Sheets("main")
            Set ws = ActiveSheet
            ws.Name = wsm.Range("B" & gyo).Value
        End If
    Next
End Sub

'取引先名称シートに伝票データをセットするマクロ
Private Sub Denpyou_DataSet()
    DenpyouSheet_Copy '取引先名称シートを作成するマクロの呼び出し
    Set wsm = Worksheets("main")
    blast = wsm.Range("B" & Rows.Count).End(xlUp).Row
    Debug.Print "B列の最後="; blast
    Dim d As Date
    
    '以下のロジックだと、 worksheet の枚数 x (blast - 1)回の計算が発生しますね。
    '見本のやり方だと、 (blast -1)回で済みます。
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Activate
            gyot = 16
            For gyo = 2 To blast
                d = wsm.Range("C" & gyo).Value
                If ws.Name = wsm.Range("B" & gyo).Value Then
                    ws.Range("B" & gyot).Value = Right(Year(d), 2)
                    ws.Range("C" & gyot).Value = Month(d)
                    ws.Range("D" & gyot).Value = day(d)
                    ws.Range("E" & gyot).Value = wsm.Range("D" & gyo).Value
                    ws.Range("F" & gyot).Value = wsm.Range("E" & gyo).Value
                    ws.Range("H" & gyot).Value = wsm.Range("F" & gyo).Value
                    If wsm.Range("G" & gyo).Value > 0 Then
                        ws.Range("I" & gyot).Value = wsm.Range("G" & gyo).Value
                    Else
                        ws.Range("J" & gyot).Value = wsm.Range("G" & gyo).Value
                    End If
                    If gyot = 16 Then
                        ws.Range("K" & gyot).Value = wsm.Range("G" & gyo).Value
                    Else
                        ws.Range("K" & gyot).Value = wsm.Range("G" & gyo).Value + ws.Range("K" & gyot - 1).Value
                    End If
                    gyot = gyot + 1
                End If
            Next
            Keisen '取引先名称シートに罫線を作成するマクロの呼び出し
        End If
    Next
End Sub

'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    ws.Activate
    elast = ws.Range("E" & Rows.Count).End(xlUp).Row
    Debug.Print "E列の最後="; elast
    
    With Range("B16:K" & elast + 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
    Range("A1").Select
End Sub

'取引先名称シートを削除するマクロ
Public Sub DenpyouSheet_Delete()
    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 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 'ワークシートを指定しました
> 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

>

受講生 さん:

添削を返送します。

Option Explicit

Sub ikkini()
    sort1
    hontai
    sort2
End Sub

Sub sort1()
    '↓シート「main」がアクティブな状態からのスタートでないと[*]エラーで止まります。以下の１行を加えるか、シート「main」上にボタンをつけ、そこからマクロを実行させるよう誘導するべき
    Worksheets("main").Activate
    
    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:=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:=Range("A2:A" & cSaigo), Type:=xlLinearTrend '[*]
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:=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
        'Elseなしで表現してください
        If ws.Name = "main" Or ws.Name = "main1" Then
        Else
            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
                keisen
            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
    keisen
End Sub

Sub keisen()
    Dim cSaigo As Long
    Dim wsNow As Worksheet
    Set wsNow = ActiveSheet
    cSaigo = wsNow.Range("B" & Rows.Count).End(xlUp).Row
'    Range("B16:K" & cSaigo).Borders(xlDiagonalDown).LineStyle = xlNone
'    Range("B16:K" & cSaigo).Borders(xlDiagonalUp).LineStyle = xlNone
'    With Range("B16:K" & cSaigo).Borders(xlEdgeLeft)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With
'    With Range("B16:K" & cSaigo).Borders(xlEdgeTop)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With
'    With Range("B16:K" & cSaigo).Borders(xlEdgeBottom)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With
'    With Range("B16:K" & cSaigo).Borders(xlEdgeRight)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With
'    With Range("B16:K" & cSaigo).Borders(xlInsideVertical)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With
'    With Range("B16:K" & cSaigo).Borders(xlInsideHorizontal)
'        .LineStyle = xlContinuous
'        .Weight = xlThin
'    End With

    '↓[1]直前の行までの様子からするに、こう書くべきですね。
    wsNow.Range("B16:K" & cSaigo).Borders(xlDiagonalDown).LineStyle = xlNone
    wsNow.Range("B16:K" & cSaigo).Borders(xlDiagonalUp).LineStyle = xlNone
    With wsNow.Range("B16:K" & cSaigo).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With wsNow.Range("B16:K" & cSaigo).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With wsNow.Range("B16:K" & cSaigo).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With wsNow.Range("B16:K" & cSaigo).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With wsNow.Range("B16:K" & cSaigo).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With wsNow.Range("B16:K" & cSaigo).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With

    '↓[2]冗長さを避けるなら、さらに、以下まで手直し
    With wsNow.Range("B16:K" & cSaigo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        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 = xlThin
        End With
    End With
End Sub

> 小川様
>
> 添削ありがとうございました。リライトいたしました。再度、添削をお願いいたします。
>
>

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:=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:=Range("A2:A" & cSaigo), Type:=xlLinearTrend
> 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:=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 ws.Name = "main" Or ws.Name = "main1" Then
>         Else
>             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
>                 keisen
>             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
>     keisen
> End Sub

>
>

Sub keisen()
>     Dim cSaigo As Long
>     Dim wsNow As Worksheet
>     Set wsNow = ActiveSheet
>     cSaigo = wsNow.Range("B" & Rows.Count).End(xlUp).Row
>     Range("B16:K" & cSaigo).Borders(xlDiagonalDown).LineStyle = xlNone
>     Range("B16:K" & cSaigo).Borders(xlDiagonalUp).LineStyle = xlNone
>     With Range("B16:K" & cSaigo).Borders(xlEdgeLeft)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Range("B16:K" & cSaigo).Borders(xlEdgeTop)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Range("B16:K" & cSaigo).Borders(xlEdgeBottom)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Range("B16:K" & cSaigo).Borders(xlEdgeRight)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Range("B16:K" & cSaigo).Borders(xlInsideVertical)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Range("B16:K" & cSaigo).Borders(xlInsideHorizontal)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
> End Sub

>

わかやまさん:

添削を返送します。

Option Explicit

Sub ikkini()
    sort1
    hontai
    '最後にA列での並べ替えを。
End Sub

Sub sort1()
    'select, selectionがなくなるまでリライトしましょう。
    '並べ替え部分はデータ数に無関係に動作するようにリライトしましょう。
    Dim kazu As Long
    Dim saigo As Long
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    saigo = Worksheets("main").Range("B65536").End(xlUp).Row '最終行が何行目でも(65536行でも1048576行でも)動くようにリライトしましょう。
    Worksheets("main").Range("A1").Value = "No."
    For kazu = 2 To saigo
        Worksheets("main").Range("A" & kazu).Value = kazu - 1
    Next
End Sub


Sub syokyo()
    Dim ws As Worksheet
    For Each ws In Worksheets
        Application.DisplayAlerts = False
        '↓elseifなしで表現してください
        If ws.Name = "main" Then
        ElseIf ws.Name = "main1" Then
        Else
            ws.Delete
        End If
        Application.DisplayAlerts = True
    Next
End Sub

Sub hontai()
    syokyo
    Dim gyo As Long
    '↓sor1ではsaigo,ここではsaigo1という名前にした理由は？重複を避けたということなら別プロシージャ内の変数なのでその心配は不要です。
    Dim saigo1 As Long
    '↓ハンガリアン記法なら、大文字小文字のメリハリをつける。発展編１本編第１章を復習のこと。
    Dim wsmain As Worksheet
    Dim wsnow As Worksheet
    Dim gyosya As String
    Dim dt As Date
    Dim saki As Long
    Set wsmain = Worksheets("main")
    saigo1 = wsmain.Range("B65536").End(xlUp).Row
    '以下はまあまあよく書けています v(^^*
    For gyo = 2 To saigo1
        If gyosya <> wsmain.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen
            End If
            Sheets("main1").Copy After:=Sheets(2)
            Sheets("main1 (2)").Name = wsmain.Range("B" & gyo).Value
            Set wsnow = ActiveSheet
            gyosya = wsnow.Name
            saki = 16
        End If
            'インデント不正。ここからNext手前までひとつ多すぎです。
            wsnow.Range("F2").Value = wsnow.Name
            wsnow.Range("H" & saki).Value = wsmain.Range("F" & gyo).Value
            wsnow.Range("F" & saki).Value = wsmain.Range("E" & gyo).Value
            wsnow.Range("E" & saki).Value = wsmain.Range("D" & gyo).Value
            dt = wsmain.Range("C" & gyo).Value
            '↓Format関数を使う方法も研究してください
            wsnow.Range("B" & saki).Value = Right(Year(dt), 2)
            wsnow.Range("C" & saki).Value = Month(dt)
            wsnow.Range("D" & saki).Value = Day(dt)
            If wsmain.Range("G" & gyo) > 0 Then
                wsnow.Range("I" & saki).Value = wsmain.Range("G" & gyo).Value
            ElseIf wsmain.Range("G" & gyo) < 0 Then
                wsnow.Range("J" & saki).Value = wsmain.Range("G" & gyo).Value
            End If
            If saki = 16 Then
                wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value
            Else
                wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value + wsnow.Range("K" & saki - 1)
            End If
            saki = saki + 1
    Next
    keisen
End Sub

Sub keisen()
    '変数名再考のこと。
    'sort1と同様、 select, selectionをなくす。
    Dim saigo2 As Long
    Dim wsnow1 As Worksheet
    Set wsnow1 = ActiveSheet
    saigo2 = wsnow1.Range("B65536").End(xlUp).Row
    Range("B16:K" & saigo2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
End Sub

> 小川様
>
> いつもありがとうございます。添削をお願いいたします。
>

Sub ikkini()
>     sort1
>     hontai
> End Sub

>
> Sub sort1()
> Dim kazu As Long
> Dim saigo As Long
> Columns("A:G").Select
> ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
> ActiveWorkbook.Worksheets("main").Sort.SortFields.Add Key:=Range("B2:B317"), _
> SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
> With ActiveWorkbook.Worksheets("main").Sort
> .SetRange Range("A1:G317")
> .Header = xlYes
> .MatchCase = False
> .Orientation = xlTopToBottom
> .SortMethod = xlPinYin
> .Apply
> End With
>
> saigo = Worksheets("main").Range("B65536").End(xlUp).Row
> Worksheets("main").Range("A1").Value = "No."
> For kazu = 2 To saigo
> Worksheets("main").Range("A" & kazu).Value = kazu - 1
> Next
> End Sub[/code]
>
>
>

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

>
>

Sub hontai()
>     syokyo
>     Dim gyo As Long
>     Dim saigo1 As Long
>     Dim wsmain As Worksheet
>     Dim wsnow As Worksheet
>     Dim gyosya As String
>     Dim dt As Date
>     Dim saki As Long
>     Set wsmain = Worksheets("main")
>     saigo1 = wsmain.Range("B65536").End(xlUp).Row
>     For gyo = 2 To saigo1
>         If gyosya <> wsmain.Range("B" & gyo).Value Then
>             If gyo > 2 Then
>                 keisen
>             End If
>             Sheets("main1").Copy After:=Sheets(2)
>             Sheets("main1 (2)").Name = wsmain.Range("B" & gyo).Value
>             Set wsnow = ActiveSheet
>             gyosya = wsnow.Name
>             saki = 16
>         End If
>             wsnow.Range("F2").Value = wsnow.Name
>             wsnow.Range("H" & saki).Value = wsmain.Range("F" & gyo).Value
>             wsnow.Range("F" & saki).Value = wsmain.Range("E" & gyo).Value
>             wsnow.Range("E" & saki).Value = wsmain.Range("D" & gyo).Value
>             dt = wsmain.Range("C" & gyo).Value
>             wsnow.Range("B" & saki).Value = Right(Year(dt), 2)
>             wsnow.Range("C" & saki).Value = Month(dt)
>             wsnow.Range("D" & saki).Value = Day(dt)
>             If wsmain.Range("G" & gyo) > 0 Then
>                 wsnow.Range("I" & saki).Value = wsmain.Range("G" & gyo).Value
>             ElseIf wsmain.Range("G" & gyo) < 0 Then
>                 wsnow.Range("J" & saki).Value = wsmain.Range("G" & gyo).Value
>             End If
>             If saki = 16 Then
>                 wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value
>             Else
>                 wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value + wsnow.Range("K" & saki - 1)
>             End If
>             saki = saki + 1
>     Next
>     keisen
> End Sub

>
>

Sub keisen()
>     Dim saigo2 As Long
>     Dim wsnow1 As Worksheet
>     Set wsnow1 = ActiveSheet
>     saigo2 = wsnow1.Range("B65536").End(xlUp).Row
>     Range("B16:K" & saigo2).Select
>     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
>     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
>     With Selection.Borders(xlEdgeLeft)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeTop)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeBottom)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeRight)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlInsideVertical)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlInsideHorizontal)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
> 
> 
> [code]Sub syokyo()
>     Dim ws As Worksheet
>     For Each ws In Worksheets
>         Application.DisplayAlerts = False
>         If ws.Name = "main" Then
>         ElseIf ws.Name = "main1" Then
>         Else
>             ws.Delete
>         End If
>         Application.DisplayAlerts = True
>     Next
> End Sub

>
>

Sub hontai()
>     syokyo
>     Dim gyo As Long
>     Dim saigo1 As Long
>     Dim wsmain As Worksheet
>     Dim wsnow As Worksheet
>     Dim gyosya As String
>     Dim dt As Date
>     Dim saki As Long
>     Set wsmain = Worksheets("main")
>     saigo1 = wsmain.Range("B65536").End(xlUp).Row
>     For gyo = 2 To saigo1
>         If gyosya <> wsmain.Range("B" & gyo).Value Then
>             If gyo > 2 Then
>                 keisen
>             End If
>             Sheets("main1").Copy After:=Sheets(2)
>             Sheets("main1 (2)").Name = wsmain.Range("B" & gyo).Value
>             Set wsnow = ActiveSheet
>             gyosya = wsnow.Name
>             saki = 16
>         End If
>             wsnow.Range("F2").Value = wsnow.Name
>             wsnow.Range("H" & saki).Value = wsmain.Range("F" & gyo).Value
>             wsnow.Range("F" & saki).Value = wsmain.Range("E" & gyo).Value
>             wsnow.Range("E" & saki).Value = wsmain.Range("D" & gyo).Value
>             dt = wsmain.Range("C" & gyo).Value
>             wsnow.Range("B" & saki).Value = Right(Year(dt), 2)
>             wsnow.Range("C" & saki).Value = Month(dt)
>             wsnow.Range("D" & saki).Value = Day(dt)
>             If wsmain.Range("G" & gyo) > 0 Then
>                 wsnow.Range("I" & saki).Value = wsmain.Range("G" & gyo).Value
>             ElseIf wsmain.Range("G" & gyo) < 0 Then
>                 wsnow.Range("J" & saki).Value = wsmain.Range("G" & gyo).Value
>             End If
>             If saki = 16 Then
>                 wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value
>             Else
>                 wsnow.Range("K" & saki) = wsmain.Range("G" & gyo).Value + wsnow.Range("K" & saki - 1)
>             End If
>             saki = saki + 1
>     Next
>     keisen
> End Sub

>
>

Sub keisen()
>     Dim saigo2 As Long
>     Dim wsnow1 As Worksheet
>     Set wsnow1 = ActiveSheet
>     saigo2 = wsnow1.Range("B65536").End(xlUp).Row
>     Range("B16:K" & saigo2).Select
>     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
>     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
>     With Selection.Borders(xlEdgeLeft)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeTop)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeBottom)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlEdgeRight)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlInsideVertical)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
>     With Selection.Borders(xlInsideHorizontal)
>         .LineStyle = xlContinuous
>         .Weight = xlThin
>     End With
> End Sub

受講生 さん:

おはようございます。

> でも、自分でも出来ることがわかったので、大変満足しております。

こういう課題をやりとげると、自己効力感高まりますよね v(^^*

添削を返送します☆

Option Explicit
'全体に、とてもよく書けています！ v(^^*
'変数名で英単語一語のものを使うのは(VBの予約語とかぶるかもしれないので)やや危険。
'dim no as long は、僕なら、他の名称にするかもしれません。
Sub narabikae_1()
    Dim ws As Worksheet
    Dim no As Long
    Dim lastRow As Long
    
    Set ws = Worksheets("main")
    lastRow = ws.Range("B65536").End(xlUp).Row
    '↓autofillを使うことも試してみてください
    For no = 2 To lastRow
        ws.Range("A" & no).Value = no - 1
    Next
        ws.Range("A1").Value = "NO" '←インデント不正
        
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("B2:B" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With

End Sub
Sub narabikae_2()
    Dim ws As Worksheet
    Dim no As Long
    Dim lastRow As Long
    
    Set ws = Worksheets("main")
    lastRow = ws.Range("B65536").End(xlUp).Row
'    For no = 2 To lastRow
'        ws.Range("A" & no).Value = no - 1
'    Next
'        ws.Range("A1").Value = "NO"
        
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange Range("A1:G" & lastRow)
        .Header = xlYes
        .Apply
    End With

End Sub
Sub denpyofukusei()
    Dim ws As Worksheet
    For Each ws In Worksheets
        If Left(ws.Name, "main") <> 4 Then
            '↓インデント過剰
                Sheets("main1").Copy After:=Sheets(2)
                Sheets("main1 (2)").Name = Worksheets("main").Range("B2").Value
        End If
    Next
End Sub
Sub denpyosakusei()
    DeleteSheets
    narabikae_1 '←より可読性の高い名前にしましょう。具体的に何をするのでしょうか？
    Dim shFm As Worksheet
    Dim meishou As String
    Dim cGyo As Long
    Dim lastRow As Long
    Dim shTo As Worksheet
    Dim saki As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    lastRow = shFm.Range("B65536").End(xlUp).Row
    
    For cGyo = 2 To lastRow
        If meishou <> shFm.Range("B" & cGyo).Value Then
            If cGyo > 2 Then
                keisen
            End If
            meishou = shFm.Range("B" & cGyo).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = meishou
            saki = 16
        End If
        shTo.Range("H" & saki).Value = shFm.Range("F" & cGyo).Value
        shTo.Range("F" & saki).Value = shFm.Range("E" & cGyo).Value
        shTo.Range("E" & saki).Value = shFm.Range("D" & cGyo).Value
        If shFm.Range("G" & cGyo).Value > 0 Then
            shTo.Range("I" & saki).Value = shFm.Range("G" & cGyo).Value
        Else
            shTo.Range("J" & saki).Value = shFm.Range("G" & cGyo).Value
        End If
'        keisen
        dt = shFm.Range("C" & cGyo).Value
        '↓format関数を使うことも試してみてください
        shTo.Range("B" & saki).Value = Right(Year(dt), 2)
        shTo.Range("C" & saki).Value = Month(dt)
        shTo.Range("D" & saki).Value = Day(dt)
        
        shTo.Range("K" & saki).Value = shTo.Range("K" & saki - 1).Value + shTo.Range("I" & saki).Value + shTo.Range("J" & saki).Value
             
            
        saki = saki + 1
    Next
    keisen
    shFm.Activate
    narabikae_2 '←より可読性の高い名前にしましょう。具体的に何をするのでしょうか？
End Sub
Sub DeleteSheets()
    Dim sh As Worksheet
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If Left(sh.Name, 4) <> "main" Then
            sh.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub keisen()
    Dim lastRow As Long
    
    lastRow = Range("B65536").End(xlUp).Row
    '↓select, selection という言葉がなくなるまでブラッシュアップを！
    Range("B16:K" & lastRow + 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

> いつもお世話になっております。
> なんとか作成出来ましたが、まだまだ時間がかかっております。でも、自分でも出来ることがわかったので、大変満足しております。作成したファイルを送らせていただきます。お手数ですが、よろしくお願いいたします。

マメコトさん:

添削を返送します。
添付ファイルは無事に受領できていました。

Option Explicit
'Module2は提出時には削除しましょう。
Sub Denpyou()
    Call Sort_First
    Call Delete_Sheets
    Call Create_Denpyou
    Call Sort_End
End Sub

Private Sub Sort_First()
    Dim Ws As Worksheet
    Dim nGyou As Long
    Dim nGyouMx As Long
    
    Set Ws = Worksheets("main")
    Ws.Range("A1").Value = "No"
    nGyouMx = Ws.Range("B" & Rows.Count).End(xlUp).Row
    
    'Autofillを使うことも検討してみてください。
    For nGyou = 2 To nGyouMx
        Ws.Range("A" & nGyou).Value = nGyou - 1
    Next
    
    '↓もうちょいwithでまとめられそう。たとえば、少なくとも[*1]以下はすべて with ws の中に入れられますね。
    Ws.Activate
    Ws.Sort.SortFields.Clear '[*1]
    Ws.Sort.SortFields.Add _
        Key:=Range("B2:B" & nGyouMx), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Ws.Sort
        .SetRange Range("A1:G" & nGyouMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

Private Sub Delete_Sheets()
    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 Create_Denpyou()

    Dim nGyouFm As Long
    Dim nGyouTo As Long
    Dim nGyouFmMx As Long
    Dim nWs As Long
    Dim WsFm As Worksheet
    Dim WsTo As Worksheet
    Dim strDate As String
    Dim strTori As String
    
    nWs = Worksheets.Count
    Set WsFm = Worksheets("main")
    nGyouFmMx = WsFm.Range("B" & Rows.Count).End(xlUp).Row
    
    '[*2], [*3]は重複している部分が多いですね。見本と比べて要再検討です。
    'あるいは、このメールセミナーの第１回から順番にやりなおしてプロセスを体験するのもよいかと。
    For nGyouFm = 2 To nGyouFmMx
        strTori = WsFm.Range("B" & nGyouFm).Value
        strDate = WsFm.Range("C" & nGyouFm).Value
        If strTori <> WsFm.Range("B" & nGyouFm - 1) Then
            Worksheets("main1").Copy after:=Worksheets(nWs)
            Worksheets(nWs + 1).Name = strTori
            nWs = nWs + 1
            Set WsTo = Worksheets(strTori)
            '[*2]
            WsTo.Range("B16").Value = Format(strDate, "yy")                             '日付（年）
            WsTo.Range("C16").Value = Format(strDate, "mm")                             '日付（月）
            WsTo.Range("D16").Value = Format(strDate, "dd")                             '日付（日）
            WsTo.Range("E16").Value = WsFm.Range("D" & nGyouFm).Value                   '会計番号
            WsTo.Range("F16").Value = WsFm.Range("E" & nGyouFm).Value                   '伝票番号
            WsTo.Range("H16").Value = WsFm.Range("F" & nGyouFm).Value                   '摘要
            If WsFm.Range("G" & nGyouFm).Value > 0 Then
                WsTo.Range("I16").Value = WsFm.Range("G" & nGyouFm).Value               '借方金額
            Else
                WsTo.Range("J16").Value = WsFm.Range("G" & nGyouFm).Value * (-1)        '貸方金額
            End If
            WsTo.Range("K16").Value = WsTo.Range("I16").Value - WsTo.Range("J16").Value '残高
            nGyouTo = 17
            If strTori <> WsFm.Range("B" & nGyouFm + 1).Value Then
                Call Add_Keisen
            End If
        Else
            '[*3]
            WsTo.Range("B" & nGyouTo).Value = Format(strDate, "yy")                             '日付（年）
            WsTo.Range("C" & nGyouTo).Value = Format(strDate, "mm")                             '日付（月）
            WsTo.Range("D" & nGyouTo).Value = Format(strDate, "dd")                             '日付（日）
            WsTo.Range("E" & nGyouTo).Value = WsFm.Range("D" & nGyouFm).Value                   '会計番号
            WsTo.Range("F" & nGyouTo).Value = WsFm.Range("E" & nGyouFm).Value                   '伝票番号
            WsTo.Range("H" & nGyouTo).Value = WsFm.Range("F" & nGyouFm).Value                   '摘要
            If WsFm.Range("G" & nGyouFm).Value > 0 Then
                WsTo.Range("I" & nGyouTo).Value = WsFm.Range("G" & nGyouFm).Value               '借方金額
            Else
                WsTo.Range("J" & nGyouTo).Value = WsFm.Range("G" & nGyouFm).Value * (-1)        '貸方金額
            End If
            WsTo.Range("K" & nGyouTo).Value = WsTo.Range("K" & nGyouTo - 1).Value _
                                                + WsTo.Range("I" & nGyouTo).Value _
                                                - WsTo.Range("J" & nGyouTo).Value               '残高
            nGyouTo = nGyouTo + 1
            If strTori <> WsFm.Range("B" & nGyouFm + 1).Value Then
                Call Add_Keisen
            End If
        End If
    Next
End Sub

Private Sub Add_Keisen()
    Dim Gyou As Long
    
    'selection の書き直しについては第１回－第９回までをやりなおす過程で学んでください
    Gyou = Range("E" & Rows.Count).End(xlUp).Row
    Range("B16:K" & Gyou).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
    Range("A1").Select
End Sub

Private Sub Sort_End()
    Dim Ws As Worksheet
    Dim nGyouMx As Long
    
    Set Ws = Worksheets("main")
    nGyouMx = Ws.Range("B" & Rows.Count).End(xlUp).Row
    
    Ws.Activate
    Ws.Sort.SortFields.Clear
    Ws.Sort.SortFields.Add _
        Key:=Range("A2:A" & nGyouMx), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Ws.Sort
        .SetRange Range("A1:G" & nGyouMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Ws.Range("A1:A" & nGyouMx).ClearContents
End Sub

> 先生のように30分では書けませんでしたが、1時間はかからずに書けました。（ボタンは作りませんでしたけど。）
> 「とりあえず動く」ものなので、マクロが記録したコードをそのまま使ったりしています。
> いかがでしょうか。

のんのんさん:

おはようございます。

発展編１レベルの演習としては、手直しはこのくらいでも十分すぎるかと思います v(^^*

イチから書いてもこのくらいのクオリティのものを書けるよう、さらに練習してください☆


> こんにちは。
> Sorting、Withを使った表現にリライトしました。
> Application.Screenupdatingも追記しました。
> よろしくお願いいたします。
>
>

> Option Explicit
> 
> Dim Retsu As String
> 'シート"main"のデータを基に伝票を作成するマクロを作れ
> 'シート"main1"は伝票のテンプレート
> Sub CreateDenpyo()
>     NumberingA
>     Retsu = "B"
>     Sorting
>     ExeCreateDenpyo
>     Retsu = "A"
>     Sorting
> End Sub
> 
> Sub NumberingA()
>     Dim lngMax As Long
>     
>     lngMax = Range("B" & Rows.Count).End(xlUp).Row
>     Range("A1").Value = "No."
>     Range("A2").Value = 1
>     Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
> End Sub
> 
> Sub Sorting()
>     Dim lngMax As Long
>     
>     lngMax = Range("B" & Rows.Count).End(xlUp).Row
>     With Worksheets("main").Sort
>         .SortFields.Clear
>         .SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
>             SortOn:=xlSortOnValues, _
>             Order:=xlAscending, _
>             DataOption:=xlSortNormal
>         .SetRange Range("A1:G" & lngMax)
>         .Header = xlYes
>         .MatchCase = False
>         .Orientation = xlTopToBottom
>         .SortMethod = xlPinYin
>         .Apply
>     End With
> End Sub
> 
> Sub ExeCreateDenpyo()
>     Dim lngMax As Long
>     Dim shtFm As Worksheet
>     Dim shtTo As Worksheet
>     Dim lngTo As Long
>     Dim lngFm As Long
>     Dim st As String
>     Dim dt As Date
>     
>     DeleteDenpyo
>     Application.ScreenUpdating = False
>     
>     'B列の値が違ったらシートを追加する
>     Set shtFm = Worksheets("main")
>     
>     lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
>     For lngFm = 2 To lngMax
>         If shtFm.Range("B" & lngFm).Value <> st Then
>             If lngFm > 2 Then
>                 Keisen
>             End If
>             st = shtFm.Range("B" & lngFm).Value
>             Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
>             Set shtTo = ActiveSheet
>             shtTo.Name = st
>             lngTo = 16
>         End If
>         
>         'データの転記
>         dt = shtFm.Range("C" & lngFm).Value
>         shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
>         shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
>         shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
>         shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
>         shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
>         shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
>         If shtFm.Range("G" & lngFm).Value > 0 Then
>             shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
>         Else
>             shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
>         End If
>         If lngTo = 16 Then
>             shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
>         Else
>             shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
>         End If
>         lngTo = lngTo + 1
>     Next
>     Keisen
>     shtFm.Activate
>     Application.ScreenUpdating = True
> End Sub
> 
> Sub DeleteDenpyo()
>     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 Keisen()
>     Dim lngMx2 As Long
>     Dim Rg As Range
>     
>     lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
>     
>     Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
>     Rg.Borders(xlDiagonalDown).LineStyle = xlNone
>     Rg.Borders(xlDiagonalUp).LineStyle = xlNone
>     With Rg.Borders(xlEdgeLeft)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeTop)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeBottom)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeRight)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlInsideVertical)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlHairline
>     End With
>     With Rg.Borders(xlInsideHorizontal)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlHairline
>     End With
> End Sub
> 

のんのんさん:

添削を返送します。

何度か書いてみて、かなり慣れましたでしょうか。

Option Explicit

Dim Retsu As String
'シート"main"のデータを基に伝票を作成するマクロを作れ
'シート"main1"は伝票のテンプレート
Sub CreateDenpyo()
    NumberingA
    Retsu = "B"
    Sorting
    ExeCreateDenpyo 'application.screenupdatingの設定を切り替えることでより高速化できます ogawa
    Retsu = "A"
    Sorting
End Sub

Sub NumberingA()
    Dim lngMax As Long
    
    lngMax = Range("B" & Rows.Count).End(xlUp).Row
    Range("A1").Value = "No."
    Range("A2").Value = 1
    Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
    '↑excellent!! autofill のほうが状況によっては高速です☆ ogawa
End Sub

Sub Sorting()
    Dim lngMax As Long
    
    lngMax = Range("B" & Rows.Count).End(xlUp).Row
    
    '↓実はもっと with を使って効率よく書けます。重複している言葉は何？ ogawa
    Worksheets("main").Sort.SortFields.Clear
    Worksheets("main").Sort.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & lngMax)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub ExeCreateDenpyo()
    Dim lngMax As Long
    Dim shtFm As Worksheet
    Dim shtTo As Worksheet
    Dim lngTo As Long
    Dim lngFm As Long
    Dim st As String
    Dim dt As Date
    
    DeleteDenpyo
    'B列の値が違ったらシートを追加する
    Set shtFm = Worksheets("main")
    
    lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
    For lngFm = 2 To lngMax
        If shtFm.Range("B" & lngFm).Value <> st Then
            If lngFm > 2 Then
                Keisen
            End If
            st = shtFm.Range("B" & lngFm).Value
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Set shtTo = ActiveSheet
            shtTo.Name = st
            lngTo = 16
        End If
        
        'データの転記
        dt = shtFm.Range("C" & lngFm).Value
        shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
        shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
        shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
        shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
        shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
        shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
        If shtFm.Range("G" & lngFm).Value > 0 Then
            shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        Else
            shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        End If
        If lngTo = 16 Then
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
        Else
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
        End If
        lngTo = lngTo + 1
    Next
    Keisen
    shtFm.Activate
End Sub

Sub DeleteDenpyo()
    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 Keisen()
    Dim lngMx2 As Long
    Dim Rg As Range
    
    lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
    Rg.Borders(xlDiagonalDown).LineStyle = xlNone
    Rg.Borders(xlDiagonalUp).LineStyle = xlNone
    With Rg.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Rg.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Rg.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Rg.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Rg.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Rg.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
End Sub

> こんにちは。
> リライトしました。よろしくお願いいたします。
>
>

> Option Explicit
> 
> Dim Retsu As String
> 'シート"main"のデータを基に伝票を作成するマクロを作れ
> 'シート"main1"は伝票のテンプレート
> Sub CreateDenpyo()
>     NumberingA
>     Retsu = "B"
>     Sorting
>     ExeCreateDenpyo
>     Retsu = "A"
>     Sorting
> End Sub
> 
> Sub NumberingA()
>     Dim lngMax As Long
>     
>     lngMax = Range("B" & Rows.Count).End(xlUp).Row
>     Range("A1").Value = "No."
>     Range("A2").Value = 1
>     Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
> End Sub
> 
> Sub Sorting()
>     Dim lngMax As Long
>     
>     lngMax = Range("B" & Rows.Count).End(xlUp).Row
>     Worksheets("main").Sort.SortFields.Clear
>     Worksheets("main").Sort.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
>         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
>     With ActiveWorkbook.Worksheets("main").Sort
>         .SetRange Range("A1:G" & lngMax)
>         .Header = xlYes
>         .MatchCase = False
>         .Orientation = xlTopToBottom
>         .SortMethod = xlPinYin
>         .Apply
>     End With
> End Sub
> 
> Sub ExeCreateDenpyo()
>     Dim lngMax As Long
>     Dim shtFm As Worksheet
>     Dim shtTo As Worksheet
>     Dim lngTo As Long
>     Dim lngFm As Long
>     Dim st As String
>     Dim dt As Date
>     
>     DeleteDenpyo
>     'B列の値が違ったらシートを追加する
>     Set shtFm = Worksheets("main")
>     
>     lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
>     For lngFm = 2 To lngMax
>         If shtFm.Range("B" & lngFm).Value <> st Then
>             If lngFm > 2 Then
>                 Keisen
>             End If
>             st = shtFm.Range("B" & lngFm).Value
>             Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
>             Set shtTo = ActiveSheet
>             shtTo.Name = st
>             lngTo = 16
>         End If
>         
>         'データの転記
>         dt = shtFm.Range("C" & lngFm).Value
>         shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
>         shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
>         shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
>         shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
>         shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
>         shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
>         If shtFm.Range("G" & lngFm).Value > 0 Then
>             shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
>         Else
>             shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
>         End If
>         If lngTo = 16 Then
>             shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
>         Else
>             shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
>         End If
>         lngTo = lngTo + 1
>     Next
>     Keisen
>     shtFm.Activate
> End Sub
> 
> Sub DeleteDenpyo()
>     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 Keisen()
>     Dim lngMx2 As Long
>     Dim Rg As Range
>     
>     lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
>     
>     Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
>     Rg.Borders(xlDiagonalDown).LineStyle = xlNone
>     Rg.Borders(xlDiagonalUp).LineStyle = xlNone
>     With Rg.Borders(xlEdgeLeft)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeTop)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeBottom)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlEdgeRight)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlThin
>     End With
>     With Rg.Borders(xlInsideVertical)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlHairline
>     End With
>     With Rg.Borders(xlInsideHorizontal)
>         .LineStyle = xlContinuous
>         .ColorIndex = 0
>         .TintAndShade = 0
>         .Weight = xlHairline
>     End With
> End Sub
> 

横山 知明さん:

こんにちは。
こちらの件、添削、無事確認されたでしょうか。

2018-06-20 11:53 の投稿です。

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






> 申し訳ありません。小川先生に、添削していただきたくて、コメントしました。私が、パートさんに仕事をお願いするときに、よく言葉足らずのところがあるので、そういう面が出てしまいました。VBAを受講させてもらい、そういう所も、少しですが改善されていると、自分では考えているので、非常に有難いです。

のんのんさん:

添削返送します。
だいぶブラッシュアップされましたね！

> 「'↓Format関数の活用も検討してください。ogawa」
> のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか？
> よろしくお願いします。

↑添削をご確認ください☆

Option Explicit

'以下の運用であれば適切です v(^^* ogawa
Dim Retsu As String

Sub CreateDenpyo()
    Application.ScreenUpdating = False
    NumberingA
    Retsu = "B"
    Sorting
    ExeCreateDenpyo
    Retsu = "A"
    Sorting
    Application.ScreenUpdating = True
End Sub

Sub NumberingA() 'シート"main"のA列に順番に番号を付けて行くマクロ
    'OKです。以下では、autofillを使った方法も検討してみてください ogawa
    
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    Dim lngGyo As Long
    
    lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Range("A1").Value = "No."
    For lngGyo = 2 To lngMax
        Range("A" & lngGyo).Value = lngGyo - 1
    Next
    
End Sub

Sub Sorting()
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    
    lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
        Key:=Range(Retsu & "2:" & Retsu & lngMax), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & lngMax)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub

Sub ExeCreateDenpyo()
    'シート"main"のB列のデータの値によって、
    'シート作成(シート"main1"のコピー)、シート名付与、データ転記するマクロ
    
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    Dim st As String    'シート名(取引先名称)を入れる
    Dim lngFm As Long
    Dim lngTo As Long
    Dim shtFm As Worksheet
    Dim shtTo As Worksheet
    
    DeleteDenpyo
    
    Set shtFm = Worksheets("main")
    shtFm.Activate
    lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
    
    Dim dt As Date 'ogawa
    For lngFm = 2 To lngMax
        If st <> shtFm.Range("B" & lngFm).Value Then
            If lngFm > 2 Then
                Keisen
            End If
            st = shtFm.Range("B" & lngFm).Value
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)    'コピー
            Set shtTo = ActiveSheet
            shtTo.Name = st 'シート名付与
            lngTo = 16
        End If
        'ここからデータ転記
'        shtTo.Range("B" & lngTo).Value = Right(Year(shtFm.Range("C" & lngFm).Value), 2)
'        shtTo.Range("C" & lngTo).Value = Month(shtFm.Range("C" & lngFm).Value)
'        shtTo.Range("D" & lngTo).Value = Day(shtFm.Range("C" & lngFm).Value)
        
        'format関数を使った例です↓ ogawa
        dt = shtFm.Range("C" & lngFm).Value
        shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
        shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
        shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
        
        shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
        shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
        shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
        If shtFm.Range("G" & lngFm).Value > 0 Then
            shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        Else
            shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        End If
        
        If lngTo = 16 Then
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
        Else
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value 'Offsetを使うのもよいですね ogawa
        End If
        lngTo = lngTo + 1
    Next
    Keisen
    Worksheets("main").Select
End Sub

Sub DeleteDenpyo()
    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 Keisen()
    Dim lngMax2 As Long
    lngMax2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    '以下では、 selection. select という言葉が登場しないようにすることも可能です。さらにリライトを!! ogawa
    ActiveSheet.Range("B16:K" & lngMax2 + 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 = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Range("A1").Activate
End Sub

> 再提出します。
> よろしくお願いします☆
>
> 前回の添削で、1か所理解できないところがありました。
>
> 「'↓Format関数の活用も検討してください。ogawa」
> のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか？
> よろしくお願いします。
>

のんのんさん:

添削を返送します。

コメントを参考にして再度挑戦してください。

Option Explicit

'モジュールレベル変数は、変数宣言の回数を減らす目的で使うものではありません。
'複数プロシージャ間で値の引き渡しをしたいときだけに使います。
'個々のプロシージャ内で完結する処理では使うとメンテナンス性が落ちるためです。
'以下でそういう意味で本当に使っている意味があるのは、 sRetsuだけです。
'発展編１の「モジュールレベル変数」の項目を復習してください。 ogawa
Dim cmMax As Long
Dim cCnt As Long
Dim wMn As Worksheet
Dim wMn1 As Worksheet
Dim wNs As Worksheet
Dim sRetsu As String
Dim cNcnt As Long
Dim cnMax As Long

Sub CreateDenpyo()
    Call rowAnumbering
    sRetsu = "B"
    Call sorting
    ExeCreateDenpyo
    Worksheets("main").Select
    sRetsu = "A"
    sorting
End Sub

Sub rowAnumbering()
    '↓Format関数の活用も検討してください。ogawa
    Set wMn = Worksheets("main")
    cmMax = wMn.Range("B" & Rows.Count).End(xlUp).Row
    wMn.Range("A1").Value = "No."
    For cCnt = 2 To cmMax
        wMn.Range("A" & cCnt).Value = cCnt - 1
    Next
End Sub

Sub sorting()
    Set wMn = Worksheets("main")
    cmMax = wMn.Range("B" & Rows.Count).End(xlUp).Row
    
    wMn.Sort.SortFields.Clear
    wMn.Sort.SortFields.Add Key:=Range(sRetsu & "2:" & sRetsu & cmMax), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With wMn.Sort
        .SetRange Range("A1:G" & cmMax)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub ExeCreateDenpyo()
    Call DeleteSheet
    Set wMn = Worksheets("main")
    cmMax = wMn.Range("B" & Rows.Count).End(xlUp).Row
    Set wMn1 = Worksheets("main1")
    
    '「次の行と違ったら」という条件で、作業対象のセルを cCnt + 1 と表現するか。
    '「前の行と違ったら」という条件で、作業対象のセルを cCnt     と表現するか。
    'というところが見本との違いですね。
    '比較すると、提出いただいたプログラムは、記述が面倒なうえ、条件文が見本よりややこしいと感じます。ogawa
    For cCnt = 1 To cmMax
        If wMn.Range("B" & cCnt).Value <> wMn.Range("B" & cCnt + 1).Value And wMn.Range("B" & cCnt + 1).Value <> "" Then
            If cCnt <> 1 Then
                Call keisen
            End If
            wMn1.Copy After:=Sheets(2)
            ActiveSheet.Name = wMn.Range("B" & cCnt + 1).Value
            Set wNs = Worksheets(ActiveSheet.Name)
            
            cNcnt = 16
            '以下は ElseIf 以下で書かれていることと重複している部分については２回書かないで済むような書き方を検討してください。 ogawa
            wNs.Range("B" & cNcnt).Value = Right(Year(wMn.Range("C" & cCnt + 1).Value), 2)
            wNs.Range("C" & cNcnt).Value = Month(wMn.Range("C" & cCnt + 1).Value)
            wNs.Range("D" & cNcnt).Value = Day(wMn.Range("C" & cCnt + 1).Value)
            wNs.Range("E" & cNcnt).Value = wMn.Range("D" & cCnt + 1).Value
            wNs.Range("F" & cNcnt).Value = wMn.Range("E" & cCnt + 1).Value
            wNs.Range("H" & cNcnt).Value = wMn.Range("F" & cCnt + 1).Value
            If wMn.Range("G" & cCnt + 1).Value > 0 Then
                wNs.Range("I" & cNcnt).Value = wMn.Range("G" & cCnt + 1).Value
            Else
                wNs.Range("J" & cNcnt).Value = wMn.Range("G" & cCnt + 1).Value
            End If
            wNs.Range("K" & cNcnt).Value = wNs.Range("I" & cNcnt).Value + wNs.Range("J" & cNcnt).Value
            cNcnt = cNcnt + 1
        ElseIf wMn.Range("B" & cCnt).Value = wMn.Range("B" & cCnt + 1).Value And wMn.Range("B" & cCnt + 1).Value <> "" Then
            wNs.Range("B" & cNcnt).Value = Right(Year(wMn.Range("C" & cCnt + 1).Value), 2)
            wNs.Range("C" & cNcnt).Value = Month(wMn.Range("C" & cCnt + 1).Value)
            wNs.Range("D" & cNcnt).Value = Day(wMn.Range("C" & cCnt + 1).Value)
            wNs.Range("E" & cNcnt).Value = wMn.Range("D" & cCnt + 1).Value
            wNs.Range("F" & cNcnt).Value = wMn.Range("E" & cCnt + 1).Value
            wNs.Range("H" & cNcnt).Value = wMn.Range("F" & cCnt + 1).Value
            If wMn.Range("G" & cCnt + 1).Value > 0 Then
                wNs.Range("I" & cNcnt).Value = wMn.Range("G" & cCnt + 1).Value
            Else
                wNs.Range("J" & cNcnt).Value = wMn.Range("G" & cCnt + 1).Value
            End If
            wNs.Range("K" & cNcnt).Value = wNs.Range("I" & cNcnt).Value + wNs.Range("J" & cNcnt).Value + wNs.Range("K" & cNcnt - 1).Value
            cNcnt = cNcnt + 1
        End If
        '↓ここでこの処理をするのと、見本のように、取引先が変わるときだけやるのとでは、どちらのほうがより効率的か？
        '  例えば、取引先数30件、データ行数100,000だったとしたら？
        '  見本のやり方なら30回で済みます。このプログラムでは、100,000回処理をすることになりますね。 ogawa
        If cCnt = cmMax Then
            Call keisen
        End If
    Next
End Sub

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

Sub keisen()
    cnMax = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
    Range("B16:K" & cnMax).Borders.LineStyle = xlContinuous
End Sub

> こんにちは。
> 伝票作成のマクロ作ってみました。
> 添削よろしくお願いします☆

横山 知明さん:

いえいえ、とんでもありません。

06-20 11:53 にここに貼った添削はもう確認されたでしょうか。
ひきつづき、よい学びになりますよう。


> 申し訳ありません。小川先生に、添削していただきたくて、コメントしました。私が、パートさんに仕事をお願いするときに、よく言葉足らずのところがあるので、そういう面が出てしまいました。VBAを受講させてもらい、そういう所も、少しですが改善されていると、自分では考えているので、非常に有難いです。

横山 知明さん:

添削を返送します。
ご自身でいろいろ考えて書かれている様子があちこちに見え、確固たる実力をつけつつあるということを実感しました。

インデントには気をつけましょう。
見本ほか僕が書いたプログラムと、様式としてどんな違いがあるか？を調べてみてください。

Option Explicit
'提出物では、よけいなモジュールはすべて削除しましょう。 ogawa
Sub CREATEDENPYO() 'エントリーのプログラムはあえてすべて大文字にする。。おもしろいですね！ ogawa
    NumberingTokuisaki
    ExeCreateDenpyo
    NarabiModosi
End Sub

'↓コメント秀逸です ogawa
Sub NumberingTokuisaki()  '---各取引明細にナンバーを付す

'sub ... end sub 内は一段インデントします。なので、以下の５行はインデント不足。他のプロシージャ内でも同様です ogawa
Dim shFm As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    shFm.Range("A1").Value = "No."
    'autofill を使う方法も研究してください ogawa
    For lnFm = 2 To lnFmMx
        shFm.Range("A" & lnFm).Value = lnFm - 1
        Debug.Print lnFm '←提出物では、出力の必要がない場合は削除 ogawa
    Next

    shFm.Range("A1:G" & lnFmMx).Select  '---取引先ごとに並び替え '←この行不要かも？いずれにせよ、 .select は極力なくなるように！ ogawa
    'with shFm.Sort. ... end with でさらに以下全体をまとめられますね。（というか、もっとまとめられますが） ogawa
    shFm.Sort.SortFields.Clear
    shFm.Sort.SortFields.Add Key:=Range("B2:B" & lnFmMx)
    With shFm.Sort
        .SetRange Range("A1:G" & lnFmMx)
        .Header = xlYes
        .Apply
    End With

End Sub
Sub NarabiModosi()

Dim shFm As Worksheet
Dim lnFmMx As Long
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    shFm.Activate
    shFm.Range("A1:G" & lnFmMx).Select  '---取引先ごとに並び替え
    shFm.Sort.SortFields.Clear
    shFm.Sort.SortFields.Add Key:=Range("A2:A" & lnFmMx)
    With shFm.Sort
        .SetRange Range("A1:G" & lnFmMx)
        .Header = xlYes
        .Apply
    End With

End Sub




Sub ExeCreateDenpyo()

ShToDelete

Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim lnToMx As Long
Dim st As String
Dim dt As Date
Dim rg As Range
Set shFm = Worksheets("main")
Set shTo = Worksheets("main1")
lnFmMx = shFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If shFm.Range("B" & lnFm) <> st Then '.Valueが抜けています。次の行も同様。 ogawa
            st = shFm.Range("B" & lnFm)
            
            '↓以下はおもしろい条件式ですね。お手本と比べての善悪を簡単に述べられません。お手本の方法でもやれるようにしましょう。 ogawa
            If shTo.Name <> "main1" Then
                lnToMx = shTo.Range("B" & Rows.Count).End(xlUp).Row
                Set rg = shTo.Range("B16:K" & lnToMx)
                With rg.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                End With
                With rg.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                End With
                With rg.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                End With
                With rg.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                End With
                With rg.Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                End With
                With rg.Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                End With
            End If
            
                        
            Worksheets("main1").Copy after:=shFm
            Set shTo = ActiveSheet
            shTo.Name = st  '---各取引先の元帳が完成
            lnTo = 16
        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
        '↓インデント余計です。 ogawa
            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
            
            '---ここから残高の転記
            If lnTo <> 16 Then
                shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + _
                                                                    shFm.Range("G" & lnFm).Value
            Else
                shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
            End If
        
        lnTo = lnTo + 1
    
    Next

    lnToMx = shTo.Range("B" & Rows.Count).End(xlUp).Row
    Set rg = shTo.Range("B16:K" & lnToMx)
    With rg
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With

'または､
'    With shTo.Range("B16:K" & lnToMx)
'        .Borders(xlEdgeLeft).LineStyle = xlContinuous
'        .Borders(xlEdgeTop).LineStyle = xlContinuous
'        .Borders(xlEdgeBottom).LineStyle = xlContinuous
'        .Borders(xlEdgeRight).LineStyle = xlContinuous
'        .Borders(xlInsideVertical).LineStyle = xlContinuous
'        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
'    End With

'    With rg.Borders(xlEdgeLeft)
'        .LineStyle = xlContinuous
'    End With
'    With rg.Borders(xlEdgeTop)
'        .LineStyle = xlContinuous
'    End With
'    With rg.Borders(xlEdgeBottom)
'        .LineStyle = xlContinuous
'    End With
'    With rg.Borders(xlEdgeRight)
'        .LineStyle = xlContinuous
'    End With
'    With rg.Borders(xlInsideVertical)
'        .LineStyle = xlContinuous
'    End With
'    With rg.Borders(xlInsideHorizontal)
'        .LineStyle = xlContinuous
'    End With


End Sub

Sub ShToDelete()  '---"main"以外のシートを削除する
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

横山 知明さん:

ああ、そうか。なるほど。
添削ということですね。

少々お待ちください。


> 宿題のつもりでなく、自分の復習で作成してみたものを送ります。
> よろしくお願いします。

横山 知明さん:

僕にどんなリアクションをご希望でしょうか。
添削希望ということでしょうか。


> 宿題のつもりでなく、自分の復習で作成してみたものを送ります。
> よろしくお願いします。

受講生 さん:

ざっと拝見しました。

このメールセミナーを通じで作ってきた見本と、先程僕からお送りした添削があります。
上記二つを参考に、今お送りいただいたこのマクロについて、自分で添削しみてください。

その添削を見てコメント差し上げたいと思います。


> すみません。
> 先ほど送信の添付ファイル間違えました。

受講生 さん:

おはようございます。
ご協力ありがとうございます。

以下、添削を貼り付けます。ご確認ください。

Option Explicit
'↓インデント不要です ogawa
'  モジュールレベル変数は、複数のプロシージャ間で情報を共有するため使うものです。
'  そうでないならば、可読性、メンテナンス性のために、個々のプロシージャ内で都度変数を宣言すべきです。
    Dim DSheet As Worksheet
    Dim FSheet As Worksheet
    Dim mxGyo As Long

Sub control_all()
'    A_retu_number '---mainのA列に№付け
'    sort_torihikisaki '---取引先名称で並べ替え
'    denpyo_sakusei '---シート作成とデータ貼り付け
'    sort_number '---№で並べ替え
    
    '可読性を考慮すると、以下のようにコメントをそろえて書くのもありです。 ogawa
    'あと、 --- とか … という記号は不要では？とも。
    A_retu_number     'mainのA列に№付け
    sort_torihikisaki '取引先名称で並べ替え
    denpyo_sakusei    'シート作成とデータ貼り付け
    sort_number       '№で並べ替え
End Sub
Sub delete_sheets() '---伝票フォーマットを全て削除
    '以下の2行不要ですね。 ogawa
    Set DSheet = Worksheets("main")
    Set FSheet = Worksheets("main1")
    
    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 '---伝票フォーマットを全て削除

    Set DSheet = Worksheets("main")
    Set FSheet = Worksheets("main1")
    
    Dim Gyo As Long
    Dim sGyo 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
        '↓以下、インデントがひとつ余計です。 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
            '↓データの件数分だけ罫線を引く作業するというのは非効率です。
            '  例えば、100,000件のデータからシートを10枚作る場合を考えてみてください。
            '  見本で示したやり方ならば、罫線を引く作業は10回で済みます。
            '  ですが、これやり方だと、罫線を引く作業が100,000回発生しますね。 ogawa
            PSheet.Range("B" & sGyo & ":K" & sGyo + 1).Borders.LineStyle = True '---罫線を引く
            PSheet.Range("F2").Value = PSheet.Name & "　実績" '---実績タイトル
            sGyo = sGyo + 1
    Next
    Application.ScreenUpdating = True '…画面更新設定
    
    DSheet.Activate

End Sub
Sub A_retu_number() '---mainのA列に№付け
    Set DSheet = Worksheets("main")

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

'№付け
    Dim Gyo 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() '---取引先名称で並べ替え
    Set DSheet = Worksheets("main")
    
    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() '---№で並べ替え
    Set DSheet = Worksheets("main")
    
    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

松井　 憲明さん:

拝見しました。
セルをアクティブに、またはセレクトするには、事前にその含まれるシートをアクティブにする必要があります。

以下、添削です。

Option Explicit
'ここまで作り込んだのであればソース内のよけいな空白行は極力潰して、可読性をより高めたいすね。 ogawa
Dim sColSort As String '小川追加。 ogawa
Sub numbering()
'putting ID numbers

    Dim gyo As Long
    Dim bot As Long  'bottomline
    Dim wm As Worksheet
    
    Set wm = Worksheets("main")
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
    
    For gyo = 2 To bot
        wm.Range("A" & gyo) = gyo - 1
    Next gyo
    wm.Range("a1").Value = "No"



End Sub


Sub sortB()

    ' sort by column B
    Dim bot As Long  'bottomline
    Dim wm As Worksheet
    
    Set wm = Worksheets("main")
    wm.Activate
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
            
    
    
    With ActiveWorkbook.Worksheets("main").Sort
        .SortFields.Clear
'        .SortFields.Add Key:=Range("B2:B" & bot), _
'        Order:=xlAscending
        .SortFields.Add Key:=Range("B2:B" & bot), Order:=xlAscending '←このくらいなら１行でいいかも。 ogawa
        .SetRange Range("A1:G" & bot)
        .Header = xlYes
        
        .Apply
    End With

        
    

End Sub

Sub sortA()

    'sort by column A that is ID number

    Dim bot As Long  'bottomline
    Dim wm As Worksheet
    
    Set wm = Worksheets("main")
    wm.Activate
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
            
   
    
    With ActiveWorkbook.Worksheets("main").Sort
        .SortFields.Clear
'        .SortFields.Add Key:=Range("A2:A" & bot), _
'        Order:=xlAscending
        .SortFields.Add Key:=Range("A2:A" & bot), Order:=xlAscending '←このくらいなら１行でいいかも。 ogawa
        .SetRange Range("A1:G" & bot)
        .Header = xlYes
        
        .Apply
    End With

        
    



End Sub



Sub CreateDenpyo()
    'create a denpyo sheet for each company listed in the "main" sheet
    Dim bot As Long  'bottomline
    Dim wm As Worksheet
    Dim w As Worksheet
    Dim gyo As Long
    Dim wm1 As Worksheet
    Dim ln As Long            'adding aline in a distination sheet
    Dim stv As Long         ' sotre the cumulative value of the invoice amounts
    Dim wd As Worksheet  ' destinatnion sheet
    
    Set wm = Worksheets("main")
    Set wm1 = Worksheets("main1")
    
'    DeleteSheets '小川案でいくならこのタイミングでの呼び出しは不要。 ogawa
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
    
    For gyo = 2 To bot
        If wm.Range("B" & gyo).Value <> wm.Range("B" & gyo - 1).Value Then
            wm1.Copy after:=Sheets(2)  'make a copy
            ActiveSheet.Name = wm.Range("B" & gyo).Value
            Set wd = Worksheets(wm.Range("B" & gyo).Value) 'Added newly to store the destination sheet into wd
            ln = 16
            stv = 0
        End If
        stv = stv + wm.Range("G" & gyo)
        wd.Range("E" & ln) = wm.Range("B" & gyo)     'move each line from the main sheet to a corresponding destination sheet
        wd.Range("f" & ln) = wm.Range("e" & gyo)    'wd was put in front to clarify the destinatnion sheet which the code works on
        wd.Range("b" & ln) = Format(wm.Range("c" & gyo), "yy") 'Format function was tried out in these three lines per Mr Ogawa's suggestion
        wd.Range("c" & ln) = Format(wm.Range("c" & gyo), "mm")
        wd.Range("d" & ln) = Format(wm.Range("c" & gyo), "dd")
        wd.Range("k" & ln) = stv
            
        If wm.Range("G" & gyo) < 0 Then 'distingush negatives from positives
            wd.Range("i" & ln) = wm.Range("G" & gyo)
        Else
            wd.Range("j" & ln) = wm.Range("G" & gyo)
        End If
        ln = ln + 1
        'keisen      'NOT A GOOD OPTION - adding "Keisen" immediately after the completion of a destinatnion sheet
    Next gyo
    
    

End Sub


Sub DeleteSheets()
    
    Dim w As Worksheet
        
    Application.DisplayAlerts = False
    
    For Each w In Worksheets
        Select Case w.Name   'used select case clause instead of If clause
            Case "main", "main1", "mainButton"
            Case Else
                w.Delete
        End Select
        
    Next
    Application.DisplayAlerts = True
    
End Sub


Sub keisen()
        
    Dim w As Worksheet
    
'    Application.ScreenUpdating = False '←末尾に =true とセットで入れたいところ。
                                        '画面のチラつき防止だけでなく、高速化にも寄与します。 ogawa
    For Each w In Worksheets
        If Left(w.Name, 4) <> "main" Then
            'adding border lines
            Dim bot As Long
                     ' w.Activate WAS REMOVED PURPOSEFULLY  TO CAUSE AN ERROR
            bot = w.Range("B" & Excel.Rows.Count).End(xlUp).Row
        
            w.Activate 'need to acitvate the worksheet including the range you want to select. ogawa
'            w.Range("B16:B" & bot & ",H16:H" & bot & ",K16:K" & bot & ",J16:J" & bot & ",I16:I" & bot & ",F16:F" & bot & ",E16:E" & bot & "").Select
'            With Selection.Borders(xlEdgeLeft)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'
'            With Selection.Borders(xlEdgeTop)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'
'            Range("B16:K" & bot).Select
'            With Selection.Borders(xlEdgeLeft)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'
'            With Selection.Borders(xlEdgeTop)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'
'            With Selection.Borders(xlEdgeBottom)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'
'            With Selection.Borders(xlEdgeRight)
'                .LineStyle = xlContinuous
'                .Weight = xlThin
'            End With
'            w.Range("B16:B" & bot & ",H16:H" & bot & ",K16:K" & bot & ",J16:J" & bot & ",I16:I" & bot & ",F16:F" & bot & ",E16:E" & bot & "").Select
            
            With w.Range("B16:K" & bot)
                With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
                
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
                
                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
                
                '以下は、内部の軽線引き。 ogawa
                With .Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                End With
            End With
        End If
        
            
    Next
'    Application.ScreenUpdating = True
    
        

        
            
        
        
        
            
End Sub

Sub PrintSet()
    '以下の設定は何もマクロで書く必要はありません。
    'エクセルのリボンから「ページレイアウト」→「ページ設定ダイアログ」で
    '（マクロ自動記録の作業すらなしで）ただ設定しておけばOKです。
    'テンプレも少しいじりました。 sub keisen... 内での処理をより簡潔に書くためです。
    'シート「main1_matsuisan」をテンプレとした場合と、仕上がりを比べてください。 ogawa

    'Print format is set to main1 sheet before it is dulpicated into new sheets
    Dim bot As Long
    Dim wm1 As Worksheet

    Set wm1 = Worksheets("main1")
              'wm1.Activate WAS REMOVED PURPOSDFULLY FOR AN ERROR TO SHOW
    bot = wm1.Range("B" & Excel.Rows.Count).End(xlUp).Row ' getting the bottom line
    Dim prg As Range
    Set prg = wm1.Range("A1:K" & bot)
    
    wm1.Activate 'need to acitvate the worksheet including the range you want to select. ogawa
    prg.Select
    ActiveSheet.PageSetup.PrintArea = prg
     
   With ActiveSheet.PageSetup
       .LeftHeader = "&F"
       .RightFooter = "&D&T"
       .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)

       .CenterHorizontally = True
       .Orientation = xlLandscape
       .PaperSize = xlPaperA4
       .FirstPageNumber = xlAutomatic
       .Order = xlDownThenOver
       .FitToPagesWide = 1
       .FitToPagesTall = 1

       .ScaleWithDocHeaderFooter = True
       
   End With


        
End Sub



Sub AllTogether()
    'そうそう。この演習では、シート作成実行ボタン、シート削除ボタンも作りますが、
    '(せっかくなので、 mainButton シート内にあるボタンももうちょい丁寧に作ってみましょう (^^; ogawa
    numbering
    sortB
'    PrintSet'当該プロシージャ先頭に記載のコメントご確認ください。 ogawa
    CreateDenpyo
    keisen
    sortA

End Sub

'↓モジュールレベル変数を使った共通化例。参考までに。 ogawa
Sub AllTogether_ogawa()
    DeleteSheets '←僕ならこのタイミングでやります。「初期化」は、作業開始前に行うべき。 ogawa
    numbering
    
    sColSort = "B"
    sortOgawa
'    PrintSet'当該プロシージャ先頭に記載のコメントご確認ください。 ogawa
    CreateDenpyo
    keisen
    
    sColSort = "A"
    sortOgawa
End Sub

'↓AllTogether_ogawa で呼び出されるもの。 ogawa
Sub sortOgawa()

    Dim bot As Long
    Dim wm As Worksheet
    
    Set wm = Worksheets("main")
    wm.Activate
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
    With ActiveWorkbook.Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(sColSort & "2:" & sColSort & bot), Order:=xlAscending  '←参考にしてください ogawa
        .SetRange Range("A1:G" & bot)
        .Header = xlYes
        .Apply
    End With
End Sub

受講生 さん:

こんばんは。

> また、PrintSet, Keisenでもなるたけ対象シートを指定、w.Rangeとか wm1.Rangeとしましたが、エラーになります。とりあえず、activateを入れると走るのでそうしてますが、せっかく明確にシートを指定したのに（VBAが誤解しにくいはず）、逆効果でエラーになるのか、首をひねっています。これもご解説いただけたら幸いです。

↑
これについては、エラーになる（けど、なっとくいかない）状態のマクロをお送りください。

添削は、それをいただいてから、と思います。

よろしくお願いします。


> 小川先生　
> 丁寧な添削いただきありがとうございました。再度、手直ししましたので、ご覧ください。
> さて、CreateDenpyoで、左辺に転出先のシートの指定を入れる件ですが、いまいちすっきりした形にできませんでした。なんか長ったらしいいので、スマートにまとめれれば、と思っております。
> また、PrintSet, Keisenでもなるたけ対象シートを指定、w.Rangeとか wm1.Rangeとしましたが、エラーになります。とりあえず、activateを入れると走るのでそうしてますが、せっかく明確にシートを指定したのに（VBAが誤解しにくいはず）、逆効果でエラーになるのか、首をひねっています。これもご解説いただけたら幸いです。
> よろしくお願いします。

受講生 さん:

追記です。

>もしシート名が original, mainみたいだと、この二つをコレクションに指定して、それ以外を削るのでしょうか？

一例としては、以下のような感じです。

Sub hoge()
    Dim w As Worksheet
    For Each w In Worksheets
        Select Case w.Name
            Case "main", "original"
            Case Else
                w.Delete
        End Select
    Next
End Sub

> 小川先生
> 毎回お世話になります。
> 今回第9回の宿題を提出させて頂きます。 もともとauto-recordingで記録した罫線、sort, printのところはエラーにならない範囲で極力削ってみましたが、各ラインの意味に不案内で、削り切れていないかもしれません。今回、DeleteFileのところで　偶然 シート名がmain, main1 で LEFT(XXX,4) <> "main"　伝票シートを削除しましたが、もしシート名が original, mainみたいだと、この二つをコレクションに指定して、それ以外を削るのでしょうか？
> よろしくお願いいたします。