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

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

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

解説

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

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

11473 : 小川慶一の回答 (2019-06-24 11:54:32)

受講生 さん:

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

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

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]「プロパティ」のサブウィンドウから、「オブジェクト名」を編集

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


11452 : 受講生さんのコメント (2019-06-14 06:49:27)

小川様

すみません、コードで囲むのですね。
3度も投稿してしまい、申し訳ございません。
よろしくお願い致します。



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()
    Dim n As Long
    For n = 2 To Range("B65536").End(xlUp).Row
        Range("A" & n).Value = n - 1
    Next
    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()
    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
    wFm.Activate
    number
    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
                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
        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
    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
End Sub


11450 : 受講生さんのコメント (2019-06-14 06:10:30)

小川様

お世話になっております。
昨日メールで添削を依頼しましたものを、こちらにも投稿致します。
よろしくお願い致します。


11222 : 受講生さんのコメント (2019-03-04 19:48:37)

小川先生 こんにちは プリントアウトの件ですが、
さっそく
Application.PrintCommunication = True
ActiveSheet.PrintPreview
を削りました。
一時停止がなくなりました。
ざっくり削ってみました。
Sub printout()
Dim sh As Worksheet
For Each sh In Worksheets
If Left(sh.Name, 4) <> "main" Then
Debug.Print sh.Name
sh.Activate


With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With

ActiveSheet.PageSetup.PrintArea = ""

With ActiveSheet.PageSetup

.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1

End With

ActiveWindow.SelectedSheets.printout Copies:=1,    Collate:=True, _
IgnorePrintAreas:=False


End If
Next

End Sub
まだまだ削り足りないと思いますが
完全にプリントアウトが出来ました。

ご指導ありがとうございました。


11220 : 小川慶一の回答 (2019-03-04 15:14:29)

受講生 さん:

ActiveSheet.PrintPreview

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

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

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


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


11217 : 受講生さんのコメント (2019-03-03 23:05:43)

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


11149 : 小川慶一の回答 (2019-02-13 21:33:26)

A.Sさん:

よかったです。

講座で学ぶ

演習を解いてみる

再度講座を見直す

リトライする

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

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




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


11136 : A.Sさんのコメント (2019-02-11 23:43:51)

小川先生

コメントありがとうございます。
見本に沿って書いてみてから再度最初から何も見ないで
書こうとしたところ、不思議と何処から手を付ければ良いのか
頭の中でイメージが出来ましたので、殆ど迷うことなく
書き上げることが出来ました。

これもひとえに小川先生のご教示があったからこそと
大変感謝の気持ちで一杯です。
現在、発展編1を受講中ですので、更にレベルを上げられるように
精進して参りたいと思います。
今後とも、ご指導の程、よろしくお願い致します。


11135 : 小川慶一の回答 (2019-02-11 22:28:13)

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


11134 : A.Sさんのコメント (2019-02-11 21:40:06)

小川先生

お忙しい中、添削誠にありがとうございます。
ご教示いただきましたとおり、見本に沿って書くということを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


11074 : 小川慶一の回答 (2019-02-04 21:30:28)

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 &lt;> 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) &lt;> "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) &lt;> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True '警告非表示解除
End Sub


11073 : A.Sさんのコメント (2019-02-04 20:32:10)

小川先生

いつも分かり易い講座をありがとうございます。
発展編1 フォローメールセミナー 第9回で宿題をいただいた伝票作成マクロを作成しましたので送らせていただきます。
自分なりに最初から作成していき、途中で詰まりながらも何とか最後まで辿り着き、動くところまで確認できました。
お忙しいところ大変恐れ入りますが、添削の程、どうぞよろしくお願い致します。


10647 : 小川慶一の回答 (2018-10-11 07:18:21)

わかやまさん:

この問題で紹介しているパターンは、使いこなせるようになると、実務での応用範囲が広いです。


> 小川様
>
> ありがとうございます。
> 同じようなコードを用いて、仕事で実践しています。
> よりよいものができるように工夫していきます。
>


10642 : わかやまさんのコメント (2018-10-10 11:37:33)

小川様

ありがとうございます。
同じようなコードを用いて、仕事で実践しています。
よりよいものができるように工夫していきます。


10638 : 小川慶一の回答 (2018-10-10 11:18:13)

わかやまさん:

その後投稿いただいた第13回のメールセミナーへのフィードバック同様、特に問題ありません。

手直しするだけでなく、イチから書き直されることをおすすめします。



> 小川様
>
> 再度、手直しいたしました。添削、どうぞよろしくお願いします。
>
>

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

>


10629 : わかやまさんのコメント (2018-10-04 04:53:28)

小川様

再度、手直しいたしました。添削、どうぞよろしくお願いします。

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


10619 : 小川慶一の回答 (2018-10-03 06:13:45)

受講生 さん:

添削を返送します。

Option Explicit

Sub ikkini()
    sort1
    hontai
    sort2
End Sub

Sub sort1()
    '↓シート「main」がアクティブな状態からのスタートでないと[*]エラーで止まります。以下の1行を加えるか、シート「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

>


10618 : 受講生さんのコメント (2018-10-03 05:06:50)

小川様

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

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


10614 : 小川慶一の回答 (2018-10-02 05:27:13)

わかやまさん:

添削を返送します。

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
    '↓ハンガリアン記法なら、大文字小文字のメリハリをつける。発展編1本編第1章を復習のこと。
    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


10611 : わかやまさんのコメント (2018-10-01 06:22:21)

小川様

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

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


10527 : 小川慶一の回答 (2018-08-30 08:47:52)

受講生 さん:

おはようございます。

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

こういう課題をやりとげると、自己効力感高まりますよね 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


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


10525 : 受講生さんのコメント (2018-08-30 08:24:57)

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


10484 : 小川慶一の回答 (2018-08-22 14:44:24)

マメコトさん:

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

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]は重複している部分が多いですね。見本と比べて要再検討です。
    'あるいは、このメールセミナーの第1回から順番にやりなおしてプロセスを体験するのもよいかと。
    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 の書き直しについては第1回-第9回までをやりなおす過程で学んでください
    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時間はかからずに書けました。(ボタンは作りませんでしたけど。)
> 「とりあえず動く」ものなので、マクロが記録したコードをそのまま使ったりしています。
> いかがでしょうか。


10470 : マメコトさんのコメント (2018-08-21 16:56:10)

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


10317 : 小川慶一の回答 (2018-08-05 10:21:44)

のんのんさん:

おはようございます。

発展編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
> 


10309 : のんのんさんのコメント (2018-08-03 01:55:25)

こんにちは。
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


10302 : 小川慶一の回答 (2018-08-02 10:35:28)

のんのんさん:

添削を返送します。

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

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
> 


10294 : のんのんさんのコメント (2018-07-29 12:45:27)

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

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


10290 : 小川慶一の回答 (2018-07-26 13:43:22)

横山 知明さん:

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

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

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






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


10289 : 小川慶一の回答 (2018-07-26 13:41:53)

のんのんさん:

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

> 「'↓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関数を使えばよいのでしょうか?
> よろしくお願いします。
>


10287 : のんのんさんのコメント (2018-07-26 00:12:49)

再提出します。
よろしくお願いします☆

前回の添削で、1か所理解できないところがありました。

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

Option Explicit

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列に順番に番号を付けて行くマクロ
    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
    
    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)
        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
    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
    
    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


10266 : 小川慶一の回答 (2018-07-16 23:51:11)

のんのんさん:

添削を返送します。

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

Option Explicit

'モジュールレベル変数は、変数宣言の回数を減らす目的で使うものではありません。
'複数プロシージャ間で値の引き渡しをしたいときだけに使います。
'個々のプロシージャ内で完結する処理では使うとメンテナンス性が落ちるためです。
'以下でそういう意味で本当に使っている意味があるのは、 sRetsuだけです。
'発展編1の「モジュールレベル変数」の項目を復習してください。 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 以下で書かれていることと重複している部分については2回書かないで済むような書き方を検討してください。 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


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


10260 : のんのんさんのコメント (2018-07-13 22:34:38)

subプロシージャを呼び出すところ、すべて Callを書いたつもりでしたが、抜けているところがありました。
投稿してから気が付きました。すみませんo(>__<)o。


10259 : のんのんさんのコメント (2018-07-13 22:31:16)

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

Option Explicit

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()
    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")
    
    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
            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
        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


10145 : 小川慶一の回答 (2018-06-21 14:13:30)

横山 知明さん:

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

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


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


10144 : 横山 知明さんのコメント (2018-06-20 12:35:11)

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


10143 : 小川慶一の回答 (2018-06-20 11:53:51)

横山 知明さん:

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

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

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

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

'sub ... end sub 内は一段インデントします。なので、以下の5行はインデント不足。他のプロシージャ内でも同様です 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


10142 : 小川慶一の回答 (2018-06-20 11:39:02)

横山 知明さん:

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

少々お待ちください。


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


10140 : 小川慶一の回答 (2018-06-20 11:36:08)

横山 知明さん:

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


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


10137 : 横山 知明さんのコメント (2018-06-20 06:56:04)

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


9856 : 小川慶一の回答 (2018-04-27 13:27:32)

受講生 さん:

ざっと拝見しました。

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

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


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


9855 : 受講生さんのコメント (2018-04-27 11:52:54)

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


9854 : 小川慶一の回答 (2018-04-27 09:48:12)

受講生 さん:

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

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

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


9853 : 受講生さんのコメント (2018-04-27 09:38:49)

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


9568 : 小川慶一の回答 (2018-03-12 09:08:10)

松井  憲明さん:

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

以下、添削です。

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 '←このくらいなら1行でいいかも。 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 '←このくらいなら1行でいいかも。 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


9565 : 松井  憲明さんのコメント (2018-03-11 20:37:06)

小川先生 activeateなしでエラーになるversion添付しました。よろしくお願いします。


9543 : 小川慶一の回答 (2018-03-08 20:27:50)

受講生 さん:

こんばんは。

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


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

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

よろしくお願いします。


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


9539 : 受講生さんのコメント (2018-03-08 06:45:01)

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


9531 : 小川慶一の回答 (2018-03-06 23:45:01)

受講生 さん:

追記です。

>もしシート名が 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みたいだと、この二つをコレクションに指定して、それ以外を削るのでしょうか?
> よろしくお願いいたします。


9530 : 小川慶一の回答 (2018-03-06 23:41:05)

松井  憲明さん:

> 小川先生  整形してみました。再度、よろしくご覧ください。お願いいたします。

インデントはかなり改善されましたね。改善前のプログラムと比較して、ご自身の感想はいかがですか。

添削の返送します。
直したいところはままありますが、全体によく書けています。

コメント参考にしてください。
そして、さらに書き直しての再提出をお願いします。

Option Explicit

Sub numbering()
'putting ID numbers

    'Good! ogwawa

    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
    
    '以下3行、不要です。残した意図は? ogawa
    wm.Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    wm.Range("A1:G" & bot).Select
    
    With ActiveWorkbook.Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B" & bot), _
        Order:=xlAscending
        .SetRange Range("A1:G" & bot)
        .Header = xlYes
        
        .Apply
    End With

    
    

End Sub

Sub sortA()
    'sortBとsortAは、並べ替え条件たる列が異なるだけです。
    'であれば、まったく同じ形になるはず...。
    'ということで、sortBでコメントしているので、ここでは重複した言及はしません。

    '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
            
    wm.Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    wm.Range("A1:G" & bot).Select
    
    With ActiveWorkbook.Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & bot), _
        Order:=xlAscending
        .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
    '↓英単語1語の変数名は好ましくないです。知らないところで、エクセルやマクロの予約語である可能性大...。 ogawa
    Dim line As Long            'adding aline in a distination sheet
    Dim store As Long         ' sotre the cumulative value of the invoice amounts
    
    Set wm = Worksheets("main")
    Set wm1 = Worksheets("main1")
    
    DeleteSheets
    bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
    
    For gyo = 2 To bot
        'きちんとした条件判定! v(^^* ogawa
        If wm.Range("B" & gyo).Value <> wm.Range("B" & gyo - 1).Value Then
            '↓以下3行、インデント多すぎです。
                '↓とはいえ、よく理解できています!ここに限らず、全体にそこはすばらしいです!
                wm1.Copy after:=Sheets(2)  'make a copy
                ActiveSheet.Name = wm.Range("B" & gyo).Value
                line = 16
                store = 0
        End If
        store = store + wm.Range("G" & gyo)
        '左辺でシートを指定していないものが多いですね。
        'このケースではたまたまOKでしたが、複数シート間での値の転記では、
        '転記先、転記元の両方でのセル指定はシートの指定から書くようにしましょう!
        'でないと、思わぬトラブルの元です。 ogawa
        Range("E" & line) = wm.Range("B" & gyo)     'move each line from the main sheet to a corresponding destination sheet
        Range("f" & line) = wm.Range("e" & gyo)
        '↓以下3行は、format関数を使う方法も調べてみてください。
        Range("b" & line) = Right(Year(wm.Range("c" & gyo)), 2)
        Range("c" & line) = Month(wm.Range("c" & gyo))
        Range("d" & line) = Day(wm.Range("c" & gyo))
        Range("k" & line) = store
            
        If wm.Range("G" & gyo) < 0 Then 'distingush negatives from positives
            '以下、インデント多すぎでした... ogawa
                Range("i" & line) = wm.Range("G" & gyo)
        Else
                Range("j" & line) = wm.Range("G" & gyo)
        End If
        line = line + 1
    Next gyo
    
    

End Sub


Sub DeleteSheets()
    'v(^_^* ogawa
    Dim bot As Long  'bottomline
    Dim wm As Worksheet
    Dim w As Worksheet
    Dim gyo As Long
    Dim wm1 As Worksheet
    
    '以下の2つも、 dim wm, dim wm1 も不要ですね。 gyo も不要。botも不要...
    '不要な変数はないか?等々、見直す習慣を! ogawa
    Set wm = Worksheets("main")
    Set wm1 = Worksheets("main1")
    
    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


Sub keisen()

    'adding border lines
    Dim bot As Long
    bot = Range("B" & Excel.Rows.Count).End(xlUp).Row

    '↓以下の .select シリーズで意味あるのは(あえて言うなら)最後のだけですね。 ogawa
    Range("B16:B" & bot & ",H16:H" & bot).Select
    Range("B" & bot & ":B" & bot & ",H" & bot & ":H" & bot & ",K" & bot & ":K" & bot).Select
    Range("B" & bot & ":B" & bot & ",H" & bot & ":H" & bot & ",K" & bot & ":K" & bot & ",J" & bot & ":J" & bot & ",I" & bot & ":I" & bot & "").Select
    Range("B" & bot & ":B" & bot & ",H" & bot & ":H" & bot & ",K" & bot & ":K" & bot & ",J" & bot & ":J" & bot & ",I" & bot & ":I" & bot & ",F" & bot).Select
    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

        
End Sub

Sub PrintSet()
    '作成後の個別シートで設定するより、テンプレたる main1 を事前にいじったほうが楽で早いです。 ogawa
    
    Dim bot As Long
        
    bot = Range("B" & Excel.Rows.Count).End(xlUp).Row ' getting the bottom line
    Dim prg As Range
    Set prg = Range("A1:K" & bot)
    
    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()
    'ネーミングよいですね! ogawa
    'ただし、納品物に問題が...。そこまできちんとチェックしてから納品してください。
    numbering
    sortB
    CreateDenpyo
    keisen   '←「宮崎繊維」以外のシートは罫線引かれませんね   (^^; ogawa
    PrintSet '←「宮崎繊維」以外のシートは書式設定されませんね (^^; ogawa
    sortA

End Sub


9525 : 松井  憲明さんのコメント (2018-03-06 07:20:12)

小川先生  整形してみました。再度、よろしくご覧ください。お願いいたします。


9520 : 小川慶一の回答 (2018-03-04 06:53:18)

受講生 さん:

ささっとまずは拝見しました。
インデントをきちんと整えてください。

例えば:

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
            
            Range("a1").Value = "No"
        


End Sub


であれば本来は以下の形です。

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

	Range("a1").Value = "No"



End Sub


コードの整形はとても大切です。
あと、もっと言うと、整形しようとしないでも自然に形が整うような書き方で書きましょう。

まずは、この件についてできる限り対応して、それから宿題再提出してください。

演習を動画を参考にしつつ解くときも、整形の仕方をしっかりマネて。
基礎編第4章は特に役に立ちますよ。


質問への回答も、それからで。

とりいそぎ。


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


9518 : 受講生さんのコメント (2018-03-03 21:40:38)

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


9465 : 小川慶一の回答 (2018-02-25 16:23:33)

受講生 さん:

よろしく!お楽しみください☆

> 小川先生
>
> ご返信頂きまして、誠にありがとうございます。
> コメント内容を確認した上で、もう一度プログラムを
> 書き直してみます。


9462 : 受講生さんのコメント (2018-02-25 15:16:07)

小川先生

ご返信頂きまして、誠にありがとうございます。
コメント内容を確認した上で、もう一度プログラムを
書き直してみます。


9448 : 小川慶一の回答 (2018-02-25 10:17:57)

受講生 さん:

添削を返送します。
とてもよく書けいてる、と思います!

ひきつづきお楽しみください v(^^*

Option Explicit

'以下の2行、インデントはしません。 ogawa
    Dim moto As Long    '転記元行番号
    Dim saki As Long    '転記先行番号
    
Sub main()  'メインの実行プロシージャ
    '↓プロシージャ名、どれもわかりやすくていいですね! ogawa
    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)
    
    Dim w As Worksheet
    
    For Each w In Worksheets
        Select Case w.Name
            '↓以下、よいですね (^^ ogawa
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
    
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    
    'autofillで値を入れる方法も調べて実装してみてください ogawa
    Dim gyo As Long
    For gyo = 2 To LastNum
        Range("A" & gyo) = gyo - 1
    Next
End Sub

Sub name_sort()     '名称で並べ替え

    Worksheets("main").Select
    Columns("A:G").Select '←不要 ogawa
    '↓以下、 good! です (^^* ogawa
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub Create_Voucher() 'シート作成用
    
    Dim LastNum As Long
        LastNum = Range("B" & Rows.Count).End(xlUp).Row '←インデントおおすぎです ogawa
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
    saki = 16 '[*1]
    
    For moto = 2 To LastNum
                                    
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then '←カッコなくても同じ条件文になります。 or が一番弱い演算子なので。とはいえ、今の段階では、こういう書き方を保険的にすることはとても良いと思います (^^* ogawa
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                '↓この saki=16 を if 文のあとに持っていけば、[*1]は不要だったかと。 ogawa
                saki = 16                                                '転送先の行番号を初期化する
            End If
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
        End If
        
        '以下の tenki, kingaku は、同じプロシージャにまとめたほうが良いかな、とも思います。やること似ていますし ogawa
        Call tenki
        Call kingaku
        saki = saki + 1
        
        '↓興味深い条件分岐ですね。
        '  ただし、for next構文のすべてでこの判断をされる、と考えると効率的には...。
        '  たとえば、元データが10万行あったとしたら、このスルーされるたけの条件判断が10万回されるわけです。
        '  ということで、僕ならfor nextの直後に最後の処理をすることにし、ここではif文は入れません。 ogawa
        If moto = LastNum Then
            Call keisen                                                  '最終行書込み後、罫線を引く
        End If
    Next
End Sub

Sub kingaku() 'お金の記載

    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        Worksheets(Worksheets.Count).Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
    
    If saki = 16 Then                                 '残高の記載
        Worksheets(Worksheets.Count).Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("K" & saki).Value = Worksheets(Worksheets.Count).Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
    
End Sub

Sub tenki()  'データの転記

    Dim shFm As Worksheet
    Set shFm = Worksheets("main")

    '↓最初の3行は、投入する値を format 関数で生成することも検討してください。 ogawa
    Worksheets(Worksheets.Count).Range("B" & saki).Value = Right(Year(shFm.Range("C" & moto).Value), 2)
    Worksheets(Worksheets.Count).Range("C" & saki).Value = Month(shFm.Range("C" & moto).Value)
    Worksheets(Worksheets.Count).Range("D" & saki).Value = Day(shFm.Range("C" & moto).Value)
    Worksheets(Worksheets.Count).Range("E" & saki).Value = shFm.Range("D" & moto).Value
    Worksheets(Worksheets.Count).Range("F" & saki).Value = shFm.Range("E" & moto).Value
    Worksheets(Worksheets.Count).Range("H" & saki).Value = shFm.Range("F" & moto).Value
End Sub

Sub keisen()  '罫線作成
    'とてもシンプルなコードになるところまで見事に昇華されましたね。すごい!! v(^^*
    'select, selection という言葉が登場しないようにリライトしてください。
    Range("B16").CurrentRegion.Select
    With Selection.Borders(xlEdgeLeft)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .Weight = xlThin
    End With
End Sub

Sub num_sort()     'Noで並べ替え

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


> 小川先生
>
> お世話になっております。
>
> 本動画の課題を投稿させて頂きます。
> (一部、google等で検索してプログラムを作成しました。)
>
> お手数ですが、添削の方よろしくお願いします。


9433 : 受講生さんのコメント (2018-02-23 19:13:07)

小川先生

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

本動画の課題を投稿させて頂きます。
(一部、google等で検索してプログラムを作成しました。)

お手数ですが、添削の方よろしくお願いします。

Option Explicit

    Dim moto As Long    '転記元行番号
    Dim saki As Long    '転記先行番号
    
Sub main()  'メインの実行プロシージャ

    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)
    
    Dim w As Worksheet
    
    For Each w In Worksheets
        Select Case w.Name
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
    
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim gyo As Long
    For gyo = 2 To LastNum
        Range("A" & gyo) = gyo - 1
    Next
End Sub

Sub name_sort()     '名称で並べ替え

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

Sub Create_Voucher() 'シート作成用
    
    Dim LastNum As Long
        LastNum = Range("B" & Rows.Count).End(xlUp).Row
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
    saki = 16
    
    For moto = 2 To LastNum
                                    
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                saki = 16                                                '転送先の行番号を初期化する
            End If
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
        End If
        
        Call tenki
        Call kingaku
        saki = saki + 1
        
        If moto = LastNum Then
            Call keisen                                                  '最終行書込み後、罫線を引く
        End If
    Next
End Sub

Sub kingaku() 'お金の記載

    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        Worksheets(Worksheets.Count).Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
    
    If saki = 16 Then                                 '残高の記載
        Worksheets(Worksheets.Count).Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("K" & saki).Value = Worksheets(Worksheets.Count).Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
    
End Sub

Sub tenki()  'データの転記

    Dim shFm As Worksheet
    Set shFm = Worksheets("main")

    Worksheets(Worksheets.Count).Range("B" & saki).Value = Right(Year(shFm.Range("C" & moto).Value), 2)
    Worksheets(Worksheets.Count).Range("C" & saki).Value = Month(shFm.Range("C" & moto).Value)
    Worksheets(Worksheets.Count).Range("D" & saki).Value = Day(shFm.Range("C" & moto).Value)
    Worksheets(Worksheets.Count).Range("E" & saki).Value = shFm.Range("D" & moto).Value
    Worksheets(Worksheets.Count).Range("F" & saki).Value = shFm.Range("E" & moto).Value
    Worksheets(Worksheets.Count).Range("H" & saki).Value = shFm.Range("F" & moto).Value
End Sub

Sub keisen()  '罫線作成

    Range("B16").CurrentRegion.Select
    With Selection.Borders(xlEdgeLeft)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .Weight = xlThin
    End With
End Sub

Sub num_sort()     'Noで並べ替え

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


9329 : 小川慶一の回答 (2018-01-05 17:16:02)

受講生 さん:

こっちは、さっき回答差し上げたものと同じでしょうか?
であれば、回答省略します。もし何かあればお知らせください!



> 小川先生
> 大変お世話になっております。
> ファイルを壊れて申し訳ないです。
> 内容は下記になります。
> Sub continueworks()
> Call sheetdelet
> Call getnumber
> Call companynamesort
> Call madedenpyo
> Call numberreturn
> End Sub
> Sub sheetdelet()
> Dim ss As Worksheet
> Application.DisplayAlerts = False
> For Each ss In Worksheets
> If Left((ss.Name), 4) <> "main" Then
> ss.Delete
> End If
> Next
> Application.DisplayAlerts = True
> End Sub
> Sub getnumber()
> Dim bango As Long
> Dim lastrow As Long
> lastrow = Range("b65536").End(xlUp).Row
> For bango = 2 To lastrow
> Worksheets("main").Range("a" & bango).Value = bango - 1
> Next
> Worksheets("main").Range("a1").Value = "No."
> End Sub
> Sub companynamesort()
> Worksheets("main").Range("A1:G317").Sort _
> key1:=Range("b2"), _
> Order1:=xlAscending, _
> Header:=xlYes
> Range("B2").Select
> End Sub
> Sub numberreturn()
> Worksheets("main").Range("A1:G317").Sort _
> key1:=Range("a2"), _
> Order1:=xlAscending, _
> Header:=xlYes
> Range("B2").Select
> End Sub
> Sub madedenpyo()
> '手順1:mainシートをコーピ作成
> '手順2:新シート名を付ける
> '手順3:新シートのRangeB~RnageKまで内容伝記
> '手順4:for Nextですべての会社名のシート作成
> '手順5:罫線作成
> Dim n As String
> Dim ctn As Long
> Dim bango As Long
> Dim lastrow As Long
> Dim dt As Date
> Dim st As Worksheet
> Dim ss As Worksheet
> Set ss = Worksheets("main")
> lastrow = ss.Range("b65536").End(xlUp).Row
> For bango = 2 To lastrow
> If n <> ss.Range("b" & bango - 1).Value Then
> If bango > 2 Then
> '罫線作成タイミングは新規シート追加される手前
> Call keisen
> End If
> n = ss.Range("b" & bango).Value
> Sheets("main1").Select
> Sheets("main1").Copy After:=Sheets(2)
> Set st = ActiveSheet
> st.Name = n
> ctn = 16
> End If
> dt = ss.Range("c" & bango).Value
> st.Range("e" & ctn).Value = ss.Range("D" & bango).Value
> st.Range("f" & ctn).Value = ss.Range("e" & bango).Value
> st.Range("h" & ctn).Value = ss.Range("f" & bango).Value
> If ss.Range("g" & bango).Value > 0 Then
> st.Range("i" & ctn).Value = ss.Range("g" & bango).Value
> Else
> st.Range("j" & ctn).Value = ss.Range("g" & bango).Value
> End If
>
> st.Range("b" & ctn).Value = Right(Year(dt), 2)
> st.Range("c" & ctn).Value = Month(dt)
> st.Range("d" & ctn).Value = Day(dt)
>
> ctn = ctn + 1
> Next
> 'ラスト伝票の罫線作成
> Call keisen
> ss.Activate
> End Sub
>
> Sub keisen()
> Dim lr As Long
> lr = Range("h65536").End(xlUp).Row
> Range("B16:K" & lr + 1).Select
> Selection.Borders(xlDiagonalDown).LineStyle = xlNone
> Selection.Borders(xlDiagonalUp).LineStyle = xlNone
> With Selection.Borders(xlEdgeLeft)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Selection.Borders(xlEdgeTop)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Selection.Borders(xlEdgeBottom)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Selection.Borders(xlEdgeRight)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Selection.Borders(xlInsideVertical)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Selection.Borders(xlInsideHorizontal)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> End Sub
>
>
>
> 大変お手数ですが、どうぞよろしくお願いいたします。


9326 : 受講生さんのコメント (2018-01-05 00:05:40)

小川先生
大変お世話になっております。
ファイルを壊れて申し訳ないです。
内容は下記になります。
Sub continueworks()
Call sheetdelet
Call getnumber
Call companynamesort
Call madedenpyo
Call numberreturn
End Sub
Sub sheetdelet()
Dim ss As Worksheet
Application.DisplayAlerts = False
For Each ss In Worksheets
If Left((ss.Name), 4) <> "main" Then
ss.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Sub getnumber()
Dim bango As Long
Dim lastrow As Long
lastrow = Range("b65536").End(xlUp).Row
For bango = 2 To lastrow
Worksheets("main").Range("a" & bango).Value = bango - 1
Next
Worksheets("main").Range("a1").Value = "No."
End Sub
Sub companynamesort()
Worksheets("main").Range("A1:G317").Sort _
key1:=Range("b2"), _
Order1:=xlAscending, _
Header:=xlYes
Range("B2").Select
End Sub
Sub numberreturn()
Worksheets("main").Range("A1:G317").Sort _
key1:=Range("a2"), _
Order1:=xlAscending, _
Header:=xlYes
Range("B2").Select
End Sub
Sub madedenpyo()
'手順1:mainシートをコーピ作成
'手順2:新シート名を付ける
'手順3:新シートのRangeB~RnageKまで内容伝記
'手順4:for Nextですべての会社名のシート作成
'手順5:罫線作成
Dim n As String
Dim ctn As Long
Dim bango As Long
Dim lastrow As Long
Dim dt As Date
Dim st As Worksheet
Dim ss As Worksheet
Set ss = Worksheets("main")
lastrow = ss.Range("b65536").End(xlUp).Row
For bango = 2 To lastrow
If n <> ss.Range("b" & bango - 1).Value Then
If bango > 2 Then
'罫線作成タイミングは新規シート追加される手前
Call keisen
End If
n = ss.Range("b" & bango).Value
Sheets("main1").Select
Sheets("main1").Copy After:=Sheets(2)
Set st = ActiveSheet
st.Name = n
ctn = 16
End If
dt = ss.Range("c" & bango).Value
st.Range("e" & ctn).Value = ss.Range("D" & bango).Value
st.Range("f" & ctn).Value = ss.Range("e" & bango).Value
st.Range("h" & ctn).Value = ss.Range("f" & bango).Value
If ss.Range("g" & bango).Value > 0 Then
st.Range("i" & ctn).Value = ss.Range("g" & bango).Value
Else
st.Range("j" & ctn).Value = ss.Range("g" & bango).Value
End If

st.Range("b" & ctn).Value = Right(Year(dt), 2)
st.Range("c" & ctn).Value = Month(dt)
st.Range("d" & ctn).Value = Day(dt)

ctn = ctn + 1
Next
'ラスト伝票の罫線作成
Call keisen
ss.Activate
End Sub

Sub keisen()
Dim lr As Long
lr = Range("h65536").End(xlUp).Row
Range("B16:K" & lr + 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub



大変お手数ですが、どうぞよろしくお願いいたします。


9229 : 小川慶一の回答 (2017-12-14 09:57:47)

三橋さん:

よかったです。
そして、ひきつづき、お楽しみください☆


9228 : 三橋さんのコメント (2017-12-14 06:50:00)

小川様

お世話になります。コメントをありがとございます。
オートフィルはコメントに従い書き直したところ、
きれいに番号が付されました。
ありがとうございました。


9223 : 小川慶一の回答 (2017-12-13 09:38:16)

三橋さん:

[1] ソース内へのコメント参照ください
[2] 全体制御するマクロに組み込むと挙動が見えてくるかと
[3], [番外編] AutofilterのSortではなく、エクセル2007以降の通常の.sortメソッドも試してみたいですね。

並べ替えについては、書くのが面倒かつ条件3つまでのときは、僕は2003までの書き方で書いています。
2007以降の.sortメソッドの記述も、慣れると味わいあって僕は嫌いではありません。あらかじめ既存の並べ替え条件すべてを削除するあたり、「伝票作成マクロ」の課題であらかじめ作成済伝票をすべて削除するのと思想が似ていますね。テキストも読んでみてください。

autofilterされていない状態で、自動記録しつつ、リボン [ホーム] → 編集グループ内の[並べ替えとフィルタ] から昇順か降順を選択。
すると、以下のようなマクロを得られます。

Worksheets("main").Sort.SortFields.Clear
Worksheets("main").Sort.SortFields.Add Key:=Range("C1"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Worksheets("main").Sort
    .SetRange Range("A2:G317")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


以下、コメントです。

'option explicit 入れましょう!念のためですが、初期設定は導入編でお伝えしたとおりにやっていますか?
'部分だけでなく、これらを呼び出す全体制御のマクロとも連動するところまで作ってみましょう。それで何度か動作確認したら、[*]の問題にも気づけたかも。
Sub GyoNarabekae2()

    Dim wsFm As Worksheet
    Dim cnt As Long
    Dim InFmMx As Long
    Set wsFm = Worksheets("main")
    InFmMx = Range("B" & Rows.Count).End(xlUp).Row

    wsFm.Range("A1").Value = "日付"

    '■■■■■Autorfillを使ってみる。
    '最低、2つのセルへの入力が必要です。以下だと、すべての行に値「1」が入ってしまいます。(excel2007で動作確認した場合) [*]
    With Range("A2")
        .Value = 1
        .AutoFill Destination:=Range("A2:A" & InFmMx)
    End With

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

Sub Narabekae2() '通常の.sortで十分なのでノーコメントです。

'■並べ替えでAutofilterを使ってみる。

    Dim wsFm As Worksheet
    Dim InFmMx As Long
    Set wsFm = Worksheets("main")
    InFmMx = Range("B" & Rows.Count).End(xlUp).Row

    wsFm.AutoFilterMode = False
    wsFm.Range("A1").AutoFilter
    wsFm.Range("A1").AutoFilter.Sort.SortFields.Add Key:=Range("B1"), _
                                                    SortOn:=xlSortOnValues, _
                                                    Order:=xlAscending, _
                                                    DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("main").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1:A" & InFmMx).ClearContents

End Sub


Sub Keisen2() '↓よく書けていると思います v(^^*

'■sub keisennでSelectionを削除したマクロ
    Dim InFmMx As Long
    InFmMx = Range("B" & Rows.Count).End(xlUp).Row

    With Range("B16:K" & InFmMx)
        .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

Sub GyoModosu2()

    '■■■■■■■行を戻すマクロ
    Dim wsFm As Worksheet
    Dim InFmMx As Long
    Set wsFm = Worksheets("main")
    InFmMx = Range("B" & Rows.Count).End(xlUp).Row
    wsFm.Range("A1:G" & InFmMx).Sort Key1:=Range("A1"), _
                                     Order1:=xlAscending, _
                                     Header:=xlYes
    Range("A1:A" & InFmMx).ClearContents

End Sub


9220 : 三橋さんのコメント (2017-12-13 07:47:09)

小川様

お世話になります。
小川さんのコメントに従い早速トライをしてみました。
添付ファイルのModule2に新たに書きました。

>[1]
> '↓autofillを使った方法も検討してみてください v(^^
> For cnt = 2 To InFmMx
> wsFm.Range("A" & cnt).Value = cnt
> Next
Sub GyoNarabekae2がそれに当たります。
お恥ずかしながら、うまくいきませんでした。
始まりを「1月」のように文字列にするとうまくいくのですが、単純に数字を入れようとすると、A列がすべて1になってしまいました。
おかしいと思い文字列の"1"から始めてみたりしたのですがうまくいきません。
申し訳ございません、ご教示いただけると助かります。

> [2]
>Sub Keisen では、 Select, Selection が登場しない書き方に
>書き改めてみてください。

小川さんのフォローメールセミナーをもとに加工しました。
sub Keisen2がそれに当たります。
ステップインで動きを見ていると、Selectionを使ったマクロでは最後に罫線がすべて書き出されていましたが、
Selectionを削除した今回提出したまくろでは、罫線を順番に引いていました。



>[3]
> Sub DenpyoZentai では、最後に、A列で並べ替えましょう。
>そうすると、マクロ実行前の状態に復元できます。
sub GyoModosu2がそれに当たります。

番外編ですが
Autofilterを使ってならば替えをしたらどうなるか、と思いトライしてみました。
Sub Narabekae2がそれに当たります。
Sortメソッドは1行で済むのに、Autofilterを使ってソートをしようとすると、こんなに多くの行が必要になるんですね。

ファイルがまた壊れているようでしたら、ご連絡いただければ、質問感想フォームに書き出します。

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


9199 : 小川慶一の回答 (2017-12-11 09:06:29)

三橋さん:

拝見しました。すばらしいです (^^*

>確かに作成に2時間しかかからなかったのは、自分でも驚きですがハナコのステップを徹底しただけなんです。
>「まずちゃんと動く(団子にあたる)コードを1行書く」ところから始まるこのステップは、私のような初心者には黄金律なようなものです。
>マクロを組むときに迷いがない。
>それがこれだけ短時間に書き上げられた要因なのかもしれません。

ですね。基本に忠実にやれば、マクロもそんなに難しくはないです。


以下の3点だけ、今後に向けてのさらなるブラッシュアップということで。

[1]
'↓autofillを使った方法も検討してみてください v(^^
For cnt = 2 To InFmMx
wsFm.Range("A" & cnt).Value = cnt
Next


[2]
Sub Keisen では、 Select, Selection が登場しない書き方に書き改めてみてください。


[3]
Sub DenpyoZentai では、最後に、A列で並べ替えましょう。
そうすると、マクロ実行前の状態に復元できます。


9198 : 三橋さんのコメント (2017-12-11 08:34:58)

小川様

お世話になります。
ファイルをメールで再送したのですが、行き違いだったようですので改めて質問感想フォームから送らせていただきます。

確かに作成に2時間しかかからなかったのは、自分でも驚きですが
ハナコのステップを徹底しただけなんです。
「まずちゃんと動く(団子にあたる)コードを1行書く」ところから始まるこのステップは、私のような初心者には黄金律なようなものです。
マクロを組むときに迷いがない。
それがこれだけ短時間に書き上げられた要因なのかもしれません。

提出させていただいたプログラムは
一見セミナーのそのままなぞったような書き方です。
ですが今回はなぞることを目的にプログラムを組みました。
変数の名前も普段なら
基礎編で学んだ「gyo…」や
ハンガリアン記法を使って「cGyo…」のように使うのですが
できるだけ短い変数を使えるようにしたかったので
メールセミナーのように
InFM/InFmMxを使ってみたりしています。
マクロを初めてまだ3か月もたっておらず知識がないため
引き出しを増やしたいと思い、そのようにさせてもらっています。

下記が宿題の回答となります。
コメントをよろしくお願いします。

Option Explicit
Sub DenpyoZentai()

Call SheetSakujo
Call GyoNarabekae
Call createDenpyo

End Sub

Sub SheetSakujo()
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 GyoNarabekae()

Dim wsFm As Worksheet
Dim cnt As Long
Dim InFmMx As Long
Set wsFm = Worksheets("main")
InFmMx = Range("B" & Rows.Count).End(xlUp).Row
For cnt = 2 To InFmMx
wsFm.Range("A" & cnt).Value = cnt
Next
wsFm.Range("A1").Value = "日付"
wsFm.Range("A1:G" & InFmMx).Sort Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes
End Sub

Sub GyoModosu()

Dim wsFm As Worksheet
Dim InFmMx As Long
Set wsFm = Worksheets("main")
InFmMx = Range("B" & Rows.Count).End(xlUp).Row
wsFm.Range("A1:G" & InFmMx).Sort Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes
Range("A1:A" & InFmMx).ClearContents

End Sub

Sub createDenpyo()
Dim wsFm As Worksheet
Dim wsTo As Worksheet
Dim InFm As Long
Dim InFmMx As Long
Dim InTo As Long
Dim dt As Long
Set wsFm = Worksheets("main")
InFmMx = Range("B" & Rows.Count).End(xlUp).Row
For InFm = 2 To InFmMx
If wsFm.Range("B" & InFm).Value <> wsFm.Range("B" & InFm).Offset(-1, 0).Value Then
If InFm > 2 Then
Call Keisen
End If
Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = wsFm.Range("B" & InFm).Value
Set wsTo = ActiveSheet
InTo = 16
End If
dt = wsFm.Range("C" & InFm).Value
wsTo.Range("B" & InTo).Value = Format(dt, "yy")
wsTo.Range("C" & InTo).Value = Format(dt, "m")
wsTo.Range("D" & InTo).Value = Format(dt, "d")
wsTo.Range("E" & InTo).Value = wsFm.Range("D" & InFm).Value
wsTo.Range("F" & InTo).Value = wsFm.Range("E" & InFm).Value
wsTo.Range("H" & InTo).Value = wsFm.Range("F" & InFm).Value
If wsFm.Range("G" & InFm).Value < 0 Then
wsTo.Range("I" & InTo).Value = wsFm.Range("G" & InFm).Value
Else
wsTo.Range("J" & InTo).Value = wsFm.Range("G" & InFm).Value
End If
If InTo = 16 Then
wsTo.Range("K16").Value = wsFm.Range("G2").Value
Else
wsTo.Range("K" & InTo).Value = wsTo.Range("K" & InTo).Offset(-1, 0).Value + wsFm.Range("G2").Value
End If
InTo = InTo + 1
Next InFm
Call Keisen
wsFm.Activate
End Sub

Sub Keisen()
'
Dim InFmMx As Long
InFmMx = Range("B" & Rows.Count).End(xlUp).Row

Range("B16:K" & InFmMx).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 = xlHairline
End With
End Sub



9180 : 小川慶一の回答 (2017-12-06 12:26:26)

三橋さん:

投稿ありがとうございます。

初回でこの課題を2時間というのは、かなり早いです!

ところで、システムからファイルを保存するまでのどこかのタイミングでファイルが壊れていたようです。
再送いただけますでしょうか。
添削用のファイル、拝見するの楽しみです (^^*


> 小川様
> お世話になります。宿題を提出させていただきます。
> メールセミナーの記憶が鮮明なうちに宿題に取り掛かったため、
> 2時間ほどで完成することができました。
> 9月から基礎編を習い始めて3か月でここまで書けるようになったことに満足しています。小川さんのおかげです。本当にありがとうございます。
>
> しかし、今回の宿題は何も見ずに自分の素の力で作ったため、
> まだ消化できていないところが発見できました。
>
> 小川さんの講義では確か文字列stを使い、
> If st <> shFm.Range("B" & lnFm).Value Then
> st = shFm.Range("B" & lnFm).Value
> とするところが、書けませんでした。
>
> 以前も質問させていただいたのですが、まだ自由に運用するまでには消化できていないことが分かり、まだまだだなぁ、と反省です。
> 先に進みたい気持ちはいっぱいですが、もう一度立ち止まって何度も自分で手で書いていこうと思っています。


9178 : 三橋さんのコメント (2017-12-06 09:03:55)

小川様
お世話になります。宿題を提出させていただきます。
メールセミナーの記憶が鮮明なうちに宿題に取り掛かったため、
2時間ほどで完成することができました。
9月から基礎編を習い始めて3か月でここまで書けるようになったことに満足しています。小川さんのおかげです。本当にありがとうございます。

しかし、今回の宿題は何も見ずに自分の素の力で作ったため、
まだ消化できていないところが発見できました。

小川さんの講義では確か文字列stを使い、
If st <> shFm.Range("B" & lnFm).Value Then
st = shFm.Range("B" & lnFm).Value
とするところが、書けませんでした。

以前も質問させていただいたのですが、まだ自由に運用するまでには消化できていないことが分かり、まだまだだなぁ、と反省です。
先に進みたい気持ちはいっぱいですが、もう一度立ち止まって何度も自分で手で書いていこうと思っています。


9028 : 受講生さんのコメント (2017-10-10 08:55:49)

小川先生

添削頂き、有難うございます。(コメント:9020)
モジュール変数の使い方等ご指摘いただき、ありがとうございます。
モジュール変数の使い方のルールがあるのですね。

フィードバックの内容を踏まえ、イチから書いています。
追加要件も実装し、動画11で再投稿いたしますので
よろしくお願いいたします。


9020 : 小川慶一の回答 (2017-10-08 20:05:20)

受講生 さん:

以下添削です。

よく書けています。
コメント参考にして、もう一度イチから書いてみてください。

Option Explicit
    '↓[1] インデント不正
    '  [2] ハンガリアン記法は、先頭のprefixは小文字で
    '  [3] モジュールレベル変数は、複数プロシージャ間で共有する情報をやりとりする場合のみに使います
    '      ひとつのプロシージャだけでしか使わないものは、そのプロシージャ内で宣言してください
    Dim WOg As Worksheet    '原本シート(main)の変数
    Dim WDa As Worksheet    'データシート(main1)の変数
    Dim WMk As Worksheet    '新規シートの変数
    Dim Ws As Worksheet     '全てのシートを示す変数
    Dim CDaRow As Long      '原本シート(main)の行を示す変数
    Dim CDaMxRow As Long    '原本シート(main)の最終行を示す変数
    Dim CMkRow As Long      '新規シートの行を指定する変数
    Dim SKey As String      'データシートの並び替えを指定する変数
    Dim St As String        'データシートの取引記録に登場する取引先を示す変数
    Dim Dtda As Date        'データシートの日付を示す変数
    
Public Sub Homework()
    Set WOg = Worksheets("main1")
    Set WDa = Worksheets("main")
    CDaMxRow = WDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DeleteDenpyou
    BangouFuri
    
    SKey = "B1"
    Narabikae
    
    CreateDenpyou
    
    SKey = "A1"
    Narabikae
    
    DeleteBangou
End Sub

Private Sub DeleteDenpyou()
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        '分岐条件がひとつしかないなら, select case ではなく if 文を使うところ。
        Select Case Left(Ws.Name, 4)
            Case "main"
            Case Else
                Ws.Delete
        End Select
    Next Ws
    Application.DisplayAlerts = True
End Sub

Private Sub BangouFuri()
    ' with wda.range("A1") と書けば with はひとつで済む。
    With WDa
        With .Range("A1")
            .Offset(0, 0).Value = "No."
            .Offset(1, 0).Value = .Offset(1, 0).Row
            .Offset(2, 0).Value = .Offset(2, 0).Row
            .Offset(3, 0).Value = .Offset(3, 0).Row
        End With
        .Range("A2:A4").AutoFill Destination:=WDa.Range("A2:A" & CDaMxRow)
    End With
End Sub

Private Sub CreateDenpyou()
    '▼新規シート作成
    CMkRow = 16 '際しの必ず[*1]でFalseになるので、そういう意味では、この行は不要。
    For CDaRow = 2 To CDaMxRow
        If St <> WDa.Range("B" & CDaRow).Value Then '[*1]
            If CDaRow > 2 Then
                Keisen
            End If
            WOg.Copy after:=Worksheets(Worksheets.Count)
            Set WMk = ActiveSheet
            St = WDa.Range("B" & CDaRow).Value
            WMk.Name = St
            CMkRow = 16
        End If
        Dtda = WDa.Range("C" & CDaRow).Value
        '▼データ転記
        With WMk
            'Right, Mid, Left等の関数でも表現可能。
            '[1]
            .Range("B" & CMkRow).Value = Format(Dtda, "yy")
            .Range("C" & CMkRow).Value = Format(Dtda, "mm")
            .Range("D" & CMkRow).Value = Format(Dtda, "dd")
            '[2]
            .Range("E" & CMkRow).Value = WDa.Range("D" & CDaRow).Value
            .Range("F" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            .Range("H" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            '[3]
            If WDa.Range("G" & CDaRow).Value > 0 Then
                .Range("I" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            Else
                .Range("J" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            End If
            'そのアプローチでいくなら。。以下なら条件分岐なしで表現できた。
            '.Range("K" & CMkRow).Value = WorksheetFunction.Sum(.Range("I16" & ":J" & CMkRow))
            '[4]
            If CMkRow = 16 Then
                .Range("K" & CMkRow).Value = _
                    WorksheetFunction.Sum(.Range("I16:J16"))
            Else
                .Range("K" & CMkRow).Value = _
                    .Range("K" & CMkRow - 1).Value + _
                    WorksheetFunction.Sum(.Range("I" & CMkRow & ":J" & CMkRow))
            End If
        End With
        CMkRow = CMkRow + 1
    Next CDaRow
    Keisen
    WDa.Activate
End Sub

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

Private Sub Narabikae()
    '↓全体を以下の構造でまとめることも可能なので、余裕があれば書き直してみてください。
    'with wda
    '    with .sort
    '        with .sortfields
    '        wnd with
    '    end with
    'end with
    'つまり、以下。
'    With WDa
'        With .Sort
'            With .SortFields
'                .Clear
'                .Add Key:=WDa.Range(SKey), Order:=xlAscending 'いただいたコードと wda.range(skey) の部分が異なるので注意
'            End With
'            .SetRange WDa.Range("A1").CurrentRegion
'            .Header = xlYes
'            .Apply
'        End With
'        .Activate
'        .Range("A1").Activate
'    End With
    
    With WDa.Sort.SortFields
        .Clear
        .Add Key:=WDa.Range(SKey), Order:=xlAscending
    End With
    With WDa.Sort
        .SetRange WDa.Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    '↓ここにあるということは、以下の2行は2回実行されるということです。1回で済ませるべき。ではどうするか?考えてみてください。
    WDa.Activate
    WDa.Range("A1").Activate
End Sub

Private Sub DeleteBangou()
    WDa.Range("A1").EntireColumn.ClearContents
End Sub


9014 : 受講生さんのコメント (2017-10-08 09:38:21)

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

宿題を投稿します。
罫線に関しては、自動記録のコードを基にネットの情報も参考にテストを繰り返して
不要と思われるコードを削除して仕上げました。
他の方の投稿と先生のコメント、勉強になります。

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

Option Explicit
    Dim WOg As Worksheet    '原本シート(main)の変数
    Dim WDa As Worksheet    'データシート(main1)の変数
    Dim WMk As Worksheet    '新規シートの変数
    Dim Ws As Worksheet     '全てのシートを示す変数
    Dim CDaRow As Long      '原本シート(main)の行を示す変数
    Dim CDaMxRow As Long    '原本シート(main)の最終行を示す変数
    Dim CMkRow As Long      '新規シートの行を指定する変数
    Dim SKey As String      'データシートの並び替えを指定する変数
    Dim St As String        'データシートの取引記録に登場する取引先を示す変数
    Dim Dtda As Date        'データシートの日付を示す変数
    
Public Sub Homework()
    Set WOg = Worksheets("main1")
    Set WDa = Worksheets("main")
    CDaMxRow = WDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DeleteDenpyou
    BangouFuri
    
    SKey = "B1"
    Narabikae
    
    CreateDenpyou
    
    SKey = "A1"
    Narabikae
    
    DeleteBangou
End Sub

Private Sub DeleteDenpyou()
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        Select Case Left(Ws.Name, 4)
            Case "main"
            Case Else
                Ws.delete
        End Select
    Next Ws
    Application.DisplayAlerts = True
End Sub

Private Sub BangouFuri()
    With WDa
        With .Range("A1")
            .Offset(0, 0).Value = "No."
            .Offset(1, 0).Value = .Offset(1, 0).Row
            .Offset(2, 0).Value = .Offset(2, 0).Row
            .Offset(3, 0).Value = .Offset(3, 0).Row
        End With
        .Range("A2:A4").AutoFill Destination:=WDa.Range("A2:A" & CDaMxRow)
    End With
End Sub

Private Sub CreateDenpyou()
    '▼新規シート作成
    CMkRow = 16
    For CDaRow = 2 To CDaMxRow
        If St <> WDa.Range("B" & CDaRow).Value Then
            If CDaRow > 2 Then
                Keisen
            End If
            WOg.Copy after:=Worksheets(Worksheets.Count)
            Set WMk = ActiveSheet
            St = WDa.Range("B" & CDaRow).Value
            WMk.Name = St
            CMkRow = 16
        End If
        Dtda = WDa.Range("C" & CDaRow).Value
        '▼データ転記
        With WMk
            '[1]
            .Range("B" & CMkRow).Value = Format(Dtda, "yy")
            .Range("C" & CMkRow).Value = Format(Dtda, "mm")
            .Range("D" & CMkRow).Value = Format(Dtda, "dd")
            '[2]
            .Range("E" & CMkRow).Value = WDa.Range("D" & CDaRow).Value
            .Range("F" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            .Range("H" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            '[3]
            If WDa.Range("G" & CDaRow).Value > 0 Then
                .Range("I" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            Else
                .Range("J" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            End If
            '[4]
            If CMkRow = 16 Then
                .Range("K" & CMkRow).Value = _
                    WorksheetFunction.Sum(.Range("I16:J16"))
            Else
                .Range("K" & CMkRow).Value = _
                    .Range("K" & CMkRow - 1).Value + _
                    WorksheetFunction.Sum(.Range("I" & CMkRow & ":J" & CMkRow))
            End If
        End With
        CMkRow = CMkRow + 1
    Next CDaRow
    Keisen
    WDa.Activate
End Sub

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

Private Sub Narabikae()
    With WDa.Sort.SortFields
        .Clear
        .Add Key:=WDa.Range(SKey), Order:=xlAscending
    End With
    With WDa.Sort
        .SetRange WDa.Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    WDa.Activate
    WDa.Range("A1").Activate
End Sub

Private Sub DeleteBangou()
    WDa.Range("A1").EntireColumn.ClearContents
End Sub


8067 : 小川慶一の回答 (2017-05-02 08:58:31)

受講生 さん:

重要な問題は特にないと思います。

> お世話になっております。
> フォームボタンの件ですが、以下のようなサブプロシジャーの記述がなくても、Excel2007の場合は、作成されたボタンを右クリックし、マクロの登録を行っても、大丈夫ですよね?
> Private Sub CommandButton2_Click()
>
> DeleteSheets
>
> End Sub


8065 : 受講生さんのコメント (2017-05-01 18:59:27)

お世話になっております。
フォームボタンの件ですが、以下のようなサブプロシジャーの記述がなくても、Excel2007の場合は、作成されたボタンを右クリックし、マクロの登録を行っても、大丈夫ですよね?
Private Sub CommandButton2_Click()

DeleteSheets

End Sub


5669 : 受講生さんのコメント (2016-01-28 08:34:48)

小川先生
いつも大変お世話になっております。
早速フォロー下さりありがとうございます。
ループの初回の回避策の別解、大変勉強になります!(・∀・)☆
"true"か"false"か、で条件分岐させる方法をとると、後からコードを見返しても分かりやすいですね。
とても応用が効きそうなので、今後活用していきたいと思います!
つい一つのやり方を身につけると、そればかりに凝り固まってしまいがちでして、別解のご教示は大変ありがたいです(・∀・)
今後ともよろしくお願いいたします。失礼いたします。


小川慶一 さん:

>受講生 さん:
>
>ちょい直してみた。このほうが可読性高いかな。変数名はこのくらい分かりやすいほうが良いですね。
>
>

Sub hoge_new()
>    Dim bShokai As Boolean '初回かどうかの判定用。[*1]に来たとき、はじめて来たときは True ,2回目以降のときは[*2]を通ったあとなので、 False が入っていることになる。
>    Dim c As Long
>    
>    bShokai = True
>    
>    For c = 2 To 317
>        
>        If 今調べている行と直前の行でセルに入っている値が違ったら Then
>            
>            If bShokai = True Then '[*1]初回だったら
>                bShokai = False    '[*2]変数bShokaiの値を True から False に変える。初回のみここに来る。
>            Else
>                'ここに来たということは初回ではないということ。
>                罫線を引く処理
>            End If
>            
>            新規シート作成
>            新規作成したシートのシート名編集
>            データ転記先行を指定する変数の値を16行目にする
>        End If
>        
>        データ転記
>        データ転記先行を指定する変数の値を1増やす
>    
>    Next
>    
>    罫線を引く処理
>End Sub


5660 : 小川慶一の回答 (2016-01-24 10:03:36)

受講生 さん:

ちょい直してみた。このほうが可読性高いかな。変数名はこのくらい分かりやすいほうが良いですね。

Sub hoge_new()
    Dim bShokai As Boolean '初回かどうかの判定用。[*1]に来たとき、はじめて来たときは True ,2回目以降のときは[*2]を通ったあとなので、 False が入っていることになる。
    Dim c As Long
    
    bShokai = True
    
    For c = 2 To 317
        
        If 今調べている行と直前の行でセルに入っている値が違ったら Then
            
            If bShokai = True Then '[*1]初回だったら
                bShokai = False    '[*2]変数bShokaiの値を True から False に変える。初回のみここに来る。
            Else
                'ここに来たということは初回ではないということ。
                罫線を引く処理
            End If
            
            新規シート作成
            新規作成したシートのシート名編集
            データ転記先行を指定する変数の値を16行目にする
        End If
        
        データ転記
        データ転記先行を指定する変数の値を1増やす
    
    Next
    
    罫線を引く処理
End Sub


5657 : 小川慶一の回答 (2016-01-24 09:48:42)

受講生 さん:

おはようございます。

>大変勉強になりました!「初回でなければ」という意味での
>If gyo<2 Then
> keisen
>だったのですね(・∀・)!!まったく閃きませんでした。

応用範囲の広い考え方です。
ぜひご活用ください。

ほかにもいろいろなやり方があります。たとえば以下。
理屈はこれのほうが分かりやすいかも?僕は変数をむやみに増やすのは好きではないのでこの方法は採りませんが、参考まで。

'初回かどうかを判定するための変数をひとつ作り、初回にその値を変えます。元の値のままなら初回と判定。値が変わっていたら2回目と判定。こういうときは、変数はBoolean型で宣言します。True/Falseで判定することになります。
Sub hoge()
    Dim b As Boolean '[*1]の条件分岐用。[*]1にはじめて来たときはFalse,2回目以降のときは[*2]を通ったあとなので、Trueが入っていることになる。
    Dim c As Long
    
    b = False 'Boolean型の変数の初期値はFalseだからこの行は無くても可。
    
    For c = 2 To 317
        
        If 今調べている行と直前の行でセルに入っている値が違ったら Then
            
            If b = True Then '[*1]この条件分岐にはじめて来るときは b の値は False。2回目以降は[*2]を通ったあとなのでTrueです。
                罫線を引く処理
            Else
                b = True '[*2]初回のみここに来る。変数bの値をFalseからTrueに変える。
            End If
            
            新規シート作成
            新規作成したシートのシート名編集
            データ転記先行を指定する変数の値を16行目にする
        End If
        
        データ転記
        データ転記先行を指定する変数の値を1増やす
    
    Next
    
    罫線を引く処理
End Sub



>小川先生、早速添削ご指導くださいましてありがとうございました。
>罫線を引くタイミングにつきまして、
>
>>「初回でなければ」という考え方でもよいです。では、初回かどうかを判定するには?→答え:「For Next構文の変数の値がカウンターの最初の値だったら」てことです。
>>For Next構文のアレンジとして、「初回だったらスキップ」、「ループを抜けた直後に追加処理」というのはよく使います。今後に向けて参考にしてください。
>
>大変勉強になりました!「初回でなければ」という意味での
>If gyo<2 Then
> keisen
>だったのですね(・∀・)!!まったく閃きませんでした。
>何故3行目以降なら罫線設定なのかということにばかりとらわれておりました。
>大変スッキリ致しました☆次の宿題作成のときにきちんと理解して書けそうです。
>他にも細やかなご指導ありがとうございました。今後の参考となりました。
>他の受講生さんの投稿等も参考にして、スッキリしたシンプルなコードが書けるように励みたいと思います(・∀・)
>それでは失礼いたします。
>
>
>
>小川慶一 さん:
>
>>受講生 さん:
>>
>>投稿ありがとうございます。全体にとてもよく書けていると思います。
>>
>>>いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
>>>特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
>>>単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
>>
>>↑それでもよいですが、「初回でなければ」という考え方でもよいです。では、初回かどうかを判定するには?→答え:「For Next構文の変数の値がカウンターの最初の値だったら」てことです。
>>
>>For Next構文のアレンジとして、「初回だったらスキップ」、「ループを抜けた直後に追加処理」というのはよく使います。今後に向けて参考にしてください。
>>次の機会に活かしてください。
>>
>>並べ替えのところのミスがやや痛い!しかしあとはとてもよくできています。


5653 : 受講生さんのコメント (2016-01-22 05:23:23)

小川先生、早速添削ご指導くださいましてありがとうございました。
罫線を引くタイミングにつきまして、

>「初回でなければ」という考え方でもよいです。では、初回かどうかを判定するには?→答え:「For Next構文の変数の値がカウンターの最初の値だったら」てことです。
>For Next構文のアレンジとして、「初回だったらスキップ」、「ループを抜けた直後に追加処理」というのはよく使います。今後に向けて参考にしてください。

大変勉強になりました!「初回でなければ」という意味での
If gyo<2 Then
keisen
だったのですね(・∀・)!!まったく閃きませんでした。
何故3行目以降なら罫線設定なのかということにばかりとらわれておりました。
大変スッキリ致しました☆次の宿題作成のときにきちんと理解して書けそうです。
他にも細やかなご指導ありがとうございました。今後の参考となりました。
他の受講生さんの投稿等も参考にして、スッキリしたシンプルなコードが書けるように励みたいと思います(・∀・)
それでは失礼いたします。



小川慶一 さん:

>受講生 さん:
>
>投稿ありがとうございます。全体にとてもよく書けていると思います。
>
>>いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
>>特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
>>単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
>
>↑それでもよいですが、「初回でなければ」という考え方でもよいです。では、初回かどうかを判定するには?→答え:「For Next構文の変数の値がカウンターの最初の値だったら」てことです。
>
>For Next構文のアレンジとして、「初回だったらスキップ」、「ループを抜けた直後に追加処理」というのはよく使います。今後に向けて参考にしてください。
>次の機会に活かしてください。
>
>並べ替えのところのミスがやや痛い!しかしあとはとてもよくできています。
>
>

'並べ替えのところが惜しい!(後述)
>'しかし、全体に、とてもよく書けています。センスのよさがうかがえます v(^^* ogawa
>Sub deleteDenpyo()
>    Dim ws As Worksheet
>    Application.DisplayAlerts = False
>    For Each ws In Worksheets
>        If ws.Name <> "main" And ws.Name <> "main1" Then
>            ws.Delete
>        End If
>    Next
>    Application.DisplayAlerts = True
>End Sub
> 
>Sub createDenpyo()
>    deleteDenpyo
>     
>    Dim wFm As Worksheet
>    Dim wTo As Worksheet
>    Set wFm = Worksheets("main")
> 
>'日付の昇順に番号振る
>    Dim gyoMax As Long
>    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
>    'Autofillを使えないか?検討してみてください。 ogawa
>    Dim gyo As Long
>    For gyo = 2 To gyoMax
>        wFm.Range("A" & gyo).Value = gyo - 1
>    Next
>     
>'B列ソート
>    '以下はも題です。2行目から317行目で header:=xlyes だと、並べ替えされる範囲は、3行目から317行目です。
>    '並べ替えする範囲はA1:G317とするか、header:=xlno  とするかでないと。
>    '(いただいたコード内容だと動作確認時にエラーで止まるはずなので、投稿前に気づくはずなのですが。。)
>    wFm.Range("A2:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes
>     
>'伝票作成
>    Dim gyoTo As Long
>    For gyo = 2 To gyoMax
>        '取引先名称が違えばシートを作る
>        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
>            If ActiveSheet.Name <> "main" Then
>                keisen
>            End If
>            Sheets("main1").Copy After:=Sheets(2)
>            Set wTo = Sheets("main1 (2)")
>            wTo.Name = wFm.Range("B" & gyo).Value
>            gyoTo = 16
>        End If
>        'シートを作成後、データを投入していく
>        wTo.Range("B" & gyoTo).Value = Mid(Year(wFm.Range("C" & gyo).Value), 3)
>        wTo.Range("C" & gyoTo).Value = Month(wFm.Range("C" & gyo).Value)
>        wTo.Range("D" & gyoTo).Value = Day(wFm.Range("C" & gyo).Value)
>         
>        wTo.Range("E" & gyoTo).Value = wFm.Range("D" & gyo).Value
>        wTo.Range("F" & gyoTo).Value = wFm.Range("E" & gyo).Value
>        wTo.Range("H" & gyoTo).Value = wFm.Range("F" & gyo).Value
>        If wFm.Range("G" & gyo).Value > 0 Then
>            wTo.Range("I" & gyoTo).Value = wFm.Range("G" & gyo).Value
>        Else
>            wTo.Range("J" & gyoTo).Value = wFm.Range("G" & gyo).Value
>        End If
>        If gyoTo = 16 Then
>            wTo.Range("K" & gyoTo).Value = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
>        Else
>            wTo.Range("K" & gyoTo).Value = wTo.Range("K" & gyoTo - 1).Value + wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
>        End If
>        gyoTo = gyoTo + 1
>    Next
>        keisen 'インデント位置注意。細かいですが。一段深すぎかと ogawa
>End Sub
> 
>Sub keisen()
>    Dim gyoToMax
>    gyoToMax = Range("B" & Rows.Count).End(xlUp).Row
>    Range("B16:K" & gyoToMax).Select '←これなくても動きます。selectは基本排除。 ogawa
>     
>    '↓エクセレント。美しいです。よく書けていますね v(^^* ogawa
>    With Range("B16:K" & gyoToMax)
>        With .Borders(xlEdgeLeft)
>            .LineStyle = xlContinuous
>            .Weight = xlThin
>        End With
>        With .Borders(xlEdgeTop)
>            .LineStyle = xlContinuous
>            .Weight = xlThin
>        End With
>        With .Borders(xlEdgeBottom)
>            .LineStyle = xlContinuous
>            .Weight = xlThin
>        End With
>        With .Borders(xlEdgeRight)
>            .LineStyle = xlContinuous
>            .Weight = xlThin
>        End With
>        With .Borders(xlInsideVertical)
>            .LineStyle = xlContinuous
>            .Weight = xlHairline
>        End With
>        With .Borders(xlInsideHorizontal)
>            .LineStyle = xlContinuous
>            .Weight = xlHairline
>        End With
>     
>    End With
>     
>End Sub

>
>
>
>>小川先生、いつも大変お世話になっております。
>>
>>昨年12月から受講開始した発展編の視聴が一通り終了しましたので、
>>年明けからフォローアップメールセミナーの伝票作成マクロに取り掛かってきました。
>>発展編での学びを定着させるのにとても勉強になっております。
>>実務の方でも非常に役に立っており、大変感謝致しております。
>>
>>この伝票作成マクロの動画を通じて、withブロックの中身を置換でシンプルに修正する方法が
>>大変参考になりました。
>>またテスト時のブレークポイントの設定についても良い復習となり、
>>実務の方で活かしていきたいと実感しました。
>>
>>以下に宿題を投稿させて頂きます。
>>先生の動画を視聴した直後に作成しましたので、殆ど先生のコードと違わないとは思いますが、
>>いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
>>特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
>>単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
>>よろしくお願いいたします。
>


5641 : 小川慶一の回答 (2016-01-18 16:16:54)

受講生 さん:

投稿ありがとうございます。全体にとてもよく書けていると思います。

>いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
>特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
>単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)

↑それでもよいですが、「初回でなければ」という考え方でもよいです。では、初回かどうかを判定するには?→答え:「For Next構文の変数の値がカウンターの最初の値だったら」てことです。

For Next構文のアレンジとして、「初回だったらスキップ」、「ループを抜けた直後に追加処理」というのはよく使います。今後に向けて参考にしてください。
次の機会に活かしてください。

並べ替えのところのミスがやや痛い!しかしあとはとてもよくできています。

'並べ替えのところが惜しい!(後述)
'しかし、全体に、とてもよく書けています。センスのよさがうかがえます v(^^* ogawa
Sub deleteDenpyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main" And ws.Name <> "main1" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
 
Sub createDenpyo()
    deleteDenpyo
     
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("main")
 
'日付の昇順に番号振る
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    'Autofillを使えないか?検討してみてください。 ogawa
    Dim gyo As Long
    For gyo = 2 To gyoMax
        wFm.Range("A" & gyo).Value = gyo - 1
    Next
     
'B列ソート
    '以下はも題です。2行目から317行目で header:=xlyes だと、並べ替えされる範囲は、3行目から317行目です。
    '並べ替えする範囲はA1:G317とするか、header:=xlno  とするかでないと。
    '(いただいたコード内容だと動作確認時にエラーで止まるはずなので、投稿前に気づくはずなのですが。。)
    wFm.Range("A2:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes
     
'伝票作成
    Dim gyoTo As Long
    For gyo = 2 To gyoMax
        '取引先名称が違えばシートを作る
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If ActiveSheet.Name <> "main" Then
                keisen
            End If
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Sheets("main1 (2)")
            wTo.Name = wFm.Range("B" & gyo).Value
            gyoTo = 16
        End If
        'シートを作成後、データを投入していく
        wTo.Range("B" & gyoTo).Value = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo).Value = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo).Value = Day(wFm.Range("C" & gyo).Value)
         
        wTo.Range("E" & gyoTo).Value = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo).Value = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo).Value = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo).Value = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo).Value = wFm.Range("G" & gyo).Value
        End If
        If gyoTo = 16 Then
            wTo.Range("K" & gyoTo).Value = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        Else
            wTo.Range("K" & gyoTo).Value = wTo.Range("K" & gyoTo - 1).Value + wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
        keisen 'インデント位置注意。細かいですが。一段深すぎかと ogawa
End Sub
 
Sub keisen()
    Dim gyoToMax
    gyoToMax = Range("B" & Rows.Count).End(xlUp).Row
    Range("B16:K" & gyoToMax).Select '←これなくても動きます。selectは基本排除。 ogawa
     
    '↓エクセレント。美しいです。よく書けていますね v(^^* ogawa
    With Range("B16:K" & gyoToMax)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
     
    End With
     
End Sub




>小川先生、いつも大変お世話になっております。
>
>昨年12月から受講開始した発展編の視聴が一通り終了しましたので、
>年明けからフォローアップメールセミナーの伝票作成マクロに取り掛かってきました。
>発展編での学びを定着させるのにとても勉強になっております。
>実務の方でも非常に役に立っており、大変感謝致しております。
>
>この伝票作成マクロの動画を通じて、withブロックの中身を置換でシンプルに修正する方法が
>大変参考になりました。
>またテスト時のブレークポイントの設定についても良い復習となり、
>実務の方で活かしていきたいと実感しました。
>
>以下に宿題を投稿させて頂きます。
>先生の動画を視聴した直後に作成しましたので、殆ど先生のコードと違わないとは思いますが、
>いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
>特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
>単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
>よろしくお願いいたします。


5633 : 受講生さんのコメント (2016-01-17 19:19:22)

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

昨年12月から受講開始した発展編の視聴が一通り終了しましたので、
年明けからフォローアップメールセミナーの伝票作成マクロに取り掛かってきました。
発展編での学びを定着させるのにとても勉強になっております。
実務の方でも非常に役に立っており、大変感謝致しております。

この伝票作成マクロの動画を通じて、withブロックの中身を置換でシンプルに修正する方法が
大変参考になりました。
またテスト時のブレークポイントの設定についても良い復習となり、
実務の方で活かしていきたいと実感しました。

以下に宿題を投稿させて頂きます。
先生の動画を視聴した直後に作成しましたので、殆ど先生のコードと違わないとは思いますが、
いざ自分で作ってみるとなると、罫線を引くタイミングが難しくて、
特にmainシートに罫線が引かれてしまう時の回避策がどうしても思いつかず、
単純に、”シート名がmainでなければ”、という表現となってしまいましたが・・・(・∀・;)
よろしくお願いいたします。


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

Sub createDenpyo()
    deleteDenpyo
    
    Dim wFm As Worksheet
    Dim wTo As Worksheet
    Set wFm = Worksheets("main")

'日付の昇順に番号振る
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim gyo As Long
    For gyo = 2 To gyoMax
        wFm.Range("A" & gyo).Value = gyo - 1
    Next
    
'B列ソート
    wFm.Range("A2:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes
    
'伝票作成
    Dim gyoTo As Long
    For gyo = 2 To gyoMax
        '取引先名称が違えばシートを作る
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If ActiveSheet.Name <> "main" Then
                keisen
            End If
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Sheets("main1 (2)")
            wTo.Name = wFm.Range("B" & gyo).Value
            gyoTo = 16
        End If
        'シートを作成後、データを投入していく
        wTo.Range("B" & gyoTo).Value = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo).Value = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo).Value = Day(wFm.Range("C" & gyo).Value)
        
        wTo.Range("E" & gyoTo).Value = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo).Value = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo).Value = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo).Value = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo).Value = wFm.Range("G" & gyo).Value
        End If
        If gyoTo = 16 Then
            wTo.Range("K" & gyoTo).Value = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        Else
            wTo.Range("K" & gyoTo).Value = wTo.Range("K" & gyoTo - 1).Value + wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
        keisen
End Sub

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



4920 : 小川慶一の回答 (2015-08-21 08:30:12)

森 則彦 さん:

添削返送します。すごくよくできてますね!サイコー!です☆

>先生から見ればまだまだ知らない初心者でレベルの低い話ではあると思いますが、

いえいえ、そんなことないです。このくらいできたら、相当のレベルですよ!

>頂上に向かって登っているときは楽し~いものですね。何歳になっても。

分かります (^^*
ひきつづき、お愉しみください☆


Sub ren212()
    DeleteSheets
    
    Dim fmWs As Worksheet, toWs As Worksheet, orWs As Worksheet
    Dim rG As Range, aLrg As Range, keiSen As Range
    Dim kaiSya As String
    Dim mX As Long, toCnt As Long, kEi As Long, kGaku As Long
    Set fmWs = Worksheets("main1")
    Set orWs = Worksheets("main")
    orWs.Range("b1").Sort key1:=Range("b1"), order1:=xlAscending, Header:=xlYes 'シンプルでいいですね! ogawa
    mX = Range("b" & Rows.Count).End(xlUp).Row
    Set aLrg = orWs.Range("b2", "b" & mX)
    For Each rG In aLrg
        '以下のIf文内のロジック、しっかりしていますね! ogawa
'        If Not kaiSya = rG Then
        If Not kaiSya = rG.Value Then 'value入れましょう ogawa
            If Not kaiSya = "" Then
                  Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt) '範囲選択の仕方、とてもうまい!スーパーエクセレント!! v(^^* ogawa
                  keiSen.Borders.LineStyle = xlContinuous '一行で済ませる方法、よくご存じですね! ogawa
            End If
            fmWs.Copy after:=Worksheets(Worksheets.Count)
            Set toWs = ActiveSheet
            kaiSya = rG.Value
            toWs.Name = kaiSya
            kEi = 0
            toCnt = 0
        End If
        'withの使い方、シブい! ogawa
        With toWs.Range("b16")
            '以下3つ、 format関数を使うことにもチャレンジしてみてください!
            .Offset(toCnt, 0).Value = Right(Year(rG.Offset(, 1).Value), 2)
            .Offset(toCnt, 1).Value = Month(rG.Offset(, 1).Value)
            .Offset(toCnt, 2).Value = Day(rG.Offset(, 1).Value)
            .Offset(toCnt, 3).Value = rG.Offset(, 2).Value
            .Offset(toCnt, 4).Value = rG.Offset(, 3).Value
            .Offset(toCnt, 6).Value = rG.Offset(, 4).Value
            kGaku = rG.Offset(, 5).Value
            If kGaku >= 0 Then
                .Offset(toCnt, 7).Value = kGaku
            Else
                .Offset(toCnt, 8).Value = kGaku
            End If
            kEi = kEi + kGaku
            .Offset(toCnt, 9).Value = kEi
        End With
        toCnt = toCnt + 1
    Next
    Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt)
    keiSen.Borders.LineStyle = xlContinuous
    orWs.Activate
    orWs.Range("a1").Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
End Sub

'good! ogawa (^^*
Sub DeleteSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Not ws.Name Like "main*" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub



>小川先生、お世話になっております。
>ちょっと時間はかかりましたが何とか出来ました。
>
>コレクションの概念をたえず意識しながら、自分なりにNETや、本などで勉強しつつ、
>先生の考え方を参考にして、違った表現で書いてみました
>
>最初よりは、やりたいことが何となくスラスラとイメージ出来る様になった気がします。
>また、他の人が書いたプログラムも読める様になったと思います。
>
>先生から見ればまだまだ知らない初心者でレベルの低い話ではあると思いますが、
>他の人の書いたものも参考にしつつスラスラと出来る様になると、遥かかなたのVBAの達人。
>頂上に向かって登っているときは楽し~いものですね。何歳になっても。
>
>以下が練習問題の私の今の力の回答です。感想よろしくお願いします。


4908 : 森 則彦さんのコメント (2015-08-21 00:22:31)

小川先生、お世話になっております。
ちょっと時間はかかりましたが何とか出来ました。

コレクションの概念をたえず意識しながら、自分なりにNETや、本などで勉強しつつ、
先生の考え方を参考にして、違った表現で書いてみました

最初よりは、やりたいことが何となくスラスラとイメージ出来る様になった気がします。
また、他の人が書いたプログラムも読める様になったと思います。

先生から見ればまだまだ知らない初心者でレベルの低い話ではあると思いますが、
他の人の書いたものも参考にしつつスラスラと出来る様になると、遥かかなたのVBAの達人。
頂上に向かって登っているときは楽し~いものですね。何歳になっても。

以下が練習問題の私の今の力の回答です。感想よろしくお願いします。


code
Sub ren212()
DeleteSheets

Dim fmWs As Worksheet, toWs As Worksheet, orWs As Worksheet
Dim rG As Range, aLrg As Range, keiSen As Range
Dim kaiSya As String
Dim mX As Long, toCnt As Long, kEi As Long, kGaku As Long
Set fmWs = Worksheets("main1")
Set orWs = Worksheets("main")
orWs.Range("b1").Sort key1:=Range("b1"), order1:=xlAscending, Header:=xlYes
mX = Range("b" & Rows.Count).End(xlUp).Row
Set aLrg = orWs.Range("b2", "b" & mX)
For Each rG In aLrg
If Not kaiSya = rG Then
If Not kaiSya = "" Then
Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt)
keiSen.Borders.LineStyle = xlContinuous
End If
fmWs.Copy after:=Worksheets(Worksheets.Count)
Set toWs = ActiveSheet
kaiSya = rG.Value
toWs.Name = kaiSya
kEi = 0
toCnt = 0
End If
With toWs.Range("b16")
.Offset(toCnt, 0).Value = Right(Year(rG.Offset(, 1).Value), 2)
.Offset(toCnt, 1).Value = Month(rG.Offset(, 1).Value)
.Offset(toCnt, 2).Value = Day(rG.Offset(, 1).Value)
.Offset(toCnt, 3).Value = rG.Offset(, 2).Value
.Offset(toCnt, 4).Value = rG.Offset(, 3).Value
.Offset(toCnt, 6).Value = rG.Offset(, 4).Value
kGaku = rG.Offset(, 5).Value
If kGaku >= 0 Then
.Offset(toCnt, 7).Value = kGaku
Else
.Offset(toCnt, 8).Value = kGaku
End If
kEi = kEi + kGaku
.Offset(toCnt, 9).Value = kEi
End With
toCnt = toCnt + 1
Next
Set keiSen = Worksheets(kaiSya).Range("b16", "k" & 15 + toCnt)
keiSen.Borders.LineStyle = xlContinuous
orWs.Activate
orWs.Range("a1").Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
End Sub


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


4888 : 小川慶一の回答 (2015-08-17 09:17:31)

受講生 さん:

よくできています。添削を返送しますね (^^

Option Explicit
Sub denpyo_sakusei_homework()
    '↓わかりやすいです (^^ ogawa
    denpyo_sakujo
    narabekae
    sheetsakusei
End Sub
 
'以下はそれぞれの部品です。
 
Sub denpyo_sakujo()            '部品1
    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 narabekae()    '部品2
Dim wfm As Worksheet 'インデントする ogawa
Set wfm = Worksheets("main") 'インデントする ogawa
 
    wfm.Range("A2").FormulaR1C1 = "1"
    wfm.Range("A3").FormulaR1C1 = "2"
    wfm.Range("A4").FormulaR1C1 = "3"
    wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
     
    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'よく書けてます (^^ ogawa
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
     
 
 
End Sub
 
Sub sheetsakusei()        '部品3
    Dim wfm As Worksheet
    Dim wto As Worksheet
    Dim cfm As Long
    Dim mx As Long
    Dim cto As Long
     
    Set wfm = Worksheets("main")
    Set wto = Worksheets("main1")
     mx = Range("B" & Rows.Count).End(xlUp).Row '一文字左へ ogawa
     
    For cfm = 2 To mx
       
        If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
            If cfm > 2 Then
                keisen
            End If
        
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
             Set wto = ActiveSheet
            wto.Name = wfm.Range("B" & cfm).Value
         cto = 16 'インデントする ogawa
        End If
      
        If wto.Name = wfm.Range("B" & cfm).Value Then
            wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
            wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
            wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
            wto.Range("J12").Value = wfm.Range("B" & cfm).Value
            '↓ よく書けてます。さらに、format関数を使った書きなおしもしてみてください (^^ ogawa
            wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
            wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
            wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
             
            If wfm.Range("G" & cfm).Value > 0 Then
                wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
            Else
                wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
            End If
          
   
          
         Dim c As Range 'この変数宣言はfornext構文の中でなく、その前に。(理由分かりますか?) ogawa
         Set c = wto.Range("K" & cto)
            If cto = 16 Then
'                c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
                c.Value = c.Offset(0, -2).Value + c.Offset(0, -1).Value 'c As Rangeなら、c.Valueでないと。 ogawa
            Else
'                c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
                c.Value = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
            End If
            cto = cto + 1
        End If
       
    Next
    keisen
     
    Worksheets("main").Activate
 
 
    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    Columns("A:A").ClearContents
     
End Sub
 
Sub keisen()          '部品4
    Dim kmx As Long
    kmx = Range("K" & Rows.Count).End(xlUp).Row
 
    With Range("B16:K" & kmx + 1) 'Withの使い方上手ですね (^^ ogawa
        .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 = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
     
 
End Sub


>小川先生
>
>ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。
>From  岡田 まさこ


4887 : 受講生さんのコメント (2015-08-16 18:36:15)

小川先生

ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。
From  岡田 まさこ

option explicit
Sub denpyo_sakusei_homework()
    denpyo_sakujo
    narabekae
    sheetsakusei
End Sub

'以下はそれぞれの部品です。

Sub denpyo_sakujo()            '部品1
    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 narabekae()    '部品2
Dim wfm As Worksheet
Set wfm = Worksheets("main")

    wfm.Range("A2").FormulaR1C1 = "1"
    wfm.Range("A3").FormulaR1C1 = "2"
    wfm.Range("A4").FormulaR1C1 = "3"
    wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
    
    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    


End Sub

Sub sheetsakusei()        '部品3
    Dim wfm As Worksheet
    Dim wto As Worksheet
    Dim cfm As Long
    Dim mx As Long
    Dim cto As Long
    
    Set wfm = Worksheets("main")
    Set wto = Worksheets("main1")
     mx = Range("B" & Rows.Count).End(xlUp).Row
    
    For cfm = 2 To mx
      
        If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
            If cfm > 2 Then
                keisen
            End If
       
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
             Set wto = ActiveSheet
            wto.Name = wfm.Range("B" & cfm).Value
         cto = 16
        End If
     
        If wto.Name = wfm.Range("B" & cfm).Value Then
            wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
            wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
            wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
            wto.Range("J12").Value = wfm.Range("B" & cfm).Value
            
            wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
            wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
            wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
            
            If wfm.Range("G" & cfm).Value > 0 Then
                wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
            Else
                wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
            End If
         
  
         
         Dim c As Range
         Set c = wto.Range("K" & cto)
            If cto = 16 Then
                c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
            Else
                c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
            End If
            cto = cto + 1
        End If
      
    Next
    keisen
    
    Worksheets("main").Activate


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

    Columns("A:A").ClearContents
    
End Sub

Sub keisen()          '部品4
    Dim kmx As Long
    kmx = Range("K" & Rows.Count).End(xlUp).Row

    With Range("B16:K" & kmx + 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 = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
    

End Sub


2766 : 小川慶一の回答 (2014-10-21 08:21:31)

匿名 さん:

シート上にボタンを設置する方法については、まあどちらでもよいです。
それぞれにメリット・デメリットはありますが、細かい違いでしかないかな、と思います。

添削は追って返送しますね。

>普段は"フォームコントロール"を使用していたのですが、今回は説明どおりに作ってみました。
>宿題もなんとか完成しました。


2758 : 受講生さんのコメント (2014-10-20 21:58:12)

普段は"フォームコントロール"を使用していたのですが、今回は説明どおりに作ってみました。
宿題もなんとか完成しました。


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

望月さん:

日々充実されているようで、なによりです。
ひきつづき、よろしくお願いいたします。


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

小川先生、セミナーの予定が次々にあり、そのフォローも度重なる中、添削ご指導ありがとうございました。こうした指導を受けられる機会は、ほんとに得難いものなので、「すごい!」の一言に尽きます。メールマガジンも含め、日々送られてくるメールには何とか一通り目を通すようにしていますが、正直、課題をこなすのに精一杯で、生かせていない事ばかりです。先生のセミナーを受講し、フォローアップの学習に取り組む生活のおかげで、今年の夏は、暑さでだらけることなく、日々充実しております。


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

望月さん、

お返事、遅くなりました。とてもよく書けています。以下、いちおう添削です。

Option Explicit
'↓[*1]まで、一段インデントを戻す
    Dim wsM As Worksheet
    Dim nGyo As Long
    Dim nSaigo As Long
    Dim stSk As String
    Dim stTn As String
    Dim wsD As Worksheet
    Dim nKisai As Long
'[*1]
Public Sub DenpyoSakusei()
    DelSheets
    BanFuri

    stSk = "B1"
    MainSort

    CreSheets

    stSk = "A1"
    MainSort

    wsM.Activate

End Sub

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

Private Sub BanFuri()
    Set wsM = Worksheets("main")
    nSaigo = wsM.Range("B" & Rows.Count).End(xlUp).Row
    wsM.Range("A1").Value = "No."
    '↓autofillでやる方法も試してみてください。やり方は、自動記録で分かります。
    For nGyo = 2 To nSaigo
        wsM.Range("A" & nGyo) = nGyo - 1
    Next
End Sub

Private Sub MainSort()
    '↓シンプルでよいと思います。
    wsM.Range("A1:G" & nSaigo).Sort _
                key1:=wsM.Range(stSk), _
                order1:=xlAscending, Header:=xlYes
End Sub

Private Sub CreSheets()
    Dim dtMh As Date
    Dim nKin As Long
    For nGyo = 2 To nSaigo
        If stTn <> wsM.Range("B" & nGyo) Then
            If nGyo > 2 Then
                Keisen
            End If
            Worksheets("main1").Copy after:=Worksheets(2)
            Set wsD = ActiveSheet
            stTn = wsM.Range("B" & nGyo)
            wsD.Name = stTn
            nKisai = 16
        End If

        wsD.Range("E" & nKisai).Value = wsM.Range("D" & nGyo).Value
        wsD.Range("F" & nKisai).Value = wsM.Range("E" & nGyo).Value
        wsD.Range("H" & nKisai).Value = wsM.Range("F" & nGyo).Value
        '↓以下4行、シンプルでいいですね。
        dtMh = wsM.Range("C" & nGyo).Value
        wsD.Range("B" & nKisai).Value = Format(dtMh, "yy")
        wsD.Range("C" & nKisai).Value = Format(dtMh, "mm")
        wsD.Range("D" & nKisai).Value = Format(dtMh, "dd")

        nKin = wsM.Range("G" & nGyo).Value
        If nKin > 0 Then
            wsD.Range("I" & nKisai).Value = nKin
        Else
            wsD.Range("J" & nKisai).Value = nKin
        End If

        If nKisai = 16 Then
            wsD.Range("K16").Value = nKin
        Else
            '↓式の表記すばらしいです
            wsD.Range("K" & nKisai).Value _
                = wsD.Range("K" & nKisai - 1).Value _
                + wsD.Range("I" & nKisai).Value _
                + wsD.Range("J" & nKisai).Value
        End If
        nKisai = nKisai + 1
    Next
    Keisen
End Sub

Private Sub Keisen()
    With wsD.Range("B16:K" & nKisai)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
    '↓以下は、上記でもOK
'    With .Borders(xlEdgeLeft)
'                            .LineStyle = xlContinuous
'                            .Weight = xlThin
'    End With
'    With .Borders(xlEdgeTop)
'                            .LineStyle = xlContinuous
'                            .Weight = xlThin
'    End With
'    With .Borders(xlEdgeBottom)
'                            .LineStyle = xlContinuous
'                            .Weight = xlThin
'    End With
'    With .Borders(xlEdgeRight)
'                            .LineStyle = xlContinuous
'                            .Weight = xlThin
'    End With
'    With .Borders(xlInsideVertical)
'                            .LineStyle = xlContinuous
'                            .Weight = xlThin
'    End With
'    With .Borders(xlInsideHorizontal)
'                            .LineStyle = xlContinuous
'                            .Weight = xlHairline
'    End With
End Sub


3228 : 望月 晋一さんのコメント (2013-08-01 21:51:00)

課題の一から作るホームワークができましたので、お送りいたします。これまで日々、発展編のフォローで取り上げている伝票作成プログラムを、通勤の行き帰りでも、何回も思い浮かべながら、全体を見渡せる理解ができるよう努めました。添削お願いいたします。

Option Explicit
    Dim wsM As Worksheet
    Dim nGyo As Long
    Dim nSaigo As Long
    Dim stSk As String
    Dim stTn As String
    Dim wsD As Worksheet
    Dim nKisai As Long

Public Sub DenpyoSakusei()
    DelSheets
    BanFuri
    
    stSk = "B1"
    MainSort
    
    CreSheets
        
    stSk = "A1"
    MainSort
    
    wsM.Activate
    
End Sub

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

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

Private Sub MainSort()
    wsM.Range("A1:G" & nSaigo).Sort _
                key1:=wsM.Range(stSk), _
                order1:=xlAscending, Header:=xlYes
End Sub

Private Sub CreSheets()
    Dim dtMh As Date
    Dim nKin As Long
    For nGyo = 2 To nSaigo
        If stTn <> wsM.Range("B" & nGyo) Then
            If nGyo > 2 Then
                Keisen
            End If
            Worksheets("main1").Copy after:=Worksheets(2)
            Set wsD = ActiveSheet
            stTn = wsM.Range("B" & nGyo)
            wsD.Name = stTn
            nKisai = 16
        End If
        
        wsD.Range("E" & nKisai).Value = wsM.Range("D" & nGyo).Value
        wsD.Range("F" & nKisai).Value = wsM.Range("E" & nGyo).Value
        wsD.Range("H" & nKisai).Value = wsM.Range("F" & nGyo).Value
        
        dtMh = wsM.Range("C" & nGyo).Value
        wsD.Range("B" & nKisai).Value = Format(dtMh, "yy")
        wsD.Range("C" & nKisai).Value = Format(dtMh, "mm")
        wsD.Range("D" & nKisai).Value = Format(dtMh, "dd")
        
        nKin = wsM.Range("G" & nGyo).Value
        If nKin > 0 Then
            wsD.Range("I" & nKisai).Value = nKin
        Else
            wsD.Range("J" & nKisai).Value = nKin
        End If
        
        If nKisai = 16 Then
            wsD.Range("K16").Value = nKin
        Else
            wsD.Range("K" & nKisai).Value _
                = wsD.Range("K" & nKisai - 1).Value _
                + wsD.Range("I" & nKisai).Value _
                + wsD.Range("J" & nKisai).Value
        End If
        nKisai = nKisai + 1
    Next
    Keisen
End Sub

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


3195 : ガラパゴスタディー事務局の回答 (2013-04-13 04:09:00)

深田さん:

お待ちしていますね!


3194 : 深田豊さんのコメント (2013-04-13 03:21:00)

僕もようやくNo.9までたどりつきました。
この週末を利用して作成したいと思います。


3135 : ガラパゴスタディー事務局の回答 (2013-02-12 00:10:00)

山根さん:

別でいただいたメールの話になりますが、
12時間どころか、3時間半でしたね (^^

上達されている証拠だと思います (^^*


3134 : 山根信行さんのコメント (2013-02-10 11:07:00)

ボタンの作成は予習で簡単にできましたが、その後の宿題を読んで驚きました。イチから作り上げるとは!
これこそ期待と不安です。

セミナー中先生からの質問で
「この伝票作成マクロ、僕ならどれくらいでできると思いますか?」
に対して
私は「15分くらいでしょうか。」
と発言しました。
先生は「僕は30分くらいです」とおっしゃったかと思います。

私はあの時心の中で(私はインターネット・参考書・自動記録を使ってもトータル24時間以上は絶対・あるいは途方もなくかかるなぁ)となんとなく思っていました。
そこで恐れ多くも(タイピングスキルは別にしてもこのセミナー終了後、このマクロが半分の12時間くらいで書ければOKとしよう)と考えました。

さて同時進行しておりました基礎編フォローセミナーも終了しました。
この宿題、時間を計測しながら毎日すこしづつ進めてまいります。


3104 : ガラパゴスタディー事務局の回答 (2013-01-21 19:03:00)

佐藤さん:

ご自身のペースで、楽しみつつ。
最初は難しかったら、あんちょこみながらでもよいですよ (^^


3102 : 佐藤 尚子さんのコメント (2013-01-21 07:03:00)

やっと№.09までたどりつきました。
自分はどのくらい時間がかかるかを見ながら
宿題を作成したいと思います。
ありがとうございました。


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

本講座の動画一覧

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

塾長 小川慶一

メニュー

コメント紹介

もっと見る

ページの先頭へ