レッスン-投稿一覧パソコン仕事５倍塾ポータル

投稿/コメントを表示します。

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

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

受講生さんの投稿

(投稿ID: 4649) 添付ファイルのダウンロード権限がありません

小川様

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

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

2020/03/28 20:34

小川慶一さんのコメント

(コメントID: 6444)

受講生さん:

こんにちは。

宿題、拝見しました。

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

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

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

End Sub

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

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

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

End Sub

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

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

以下は別解等です。

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

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

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

'↓sort_name, sort_no はkeyになる列が異なるだけ。
'  なので、１つのプロシージャだけで、モジュールレベル変数を使って使い回せるようにも書けます。
'  (発展編2レベルのノウハウを使うなら、モジュールレベル変数ではなく、引数つきプロシージャで)
'  あとは、 Range("A1:G317") の代わりに currentregion を使うとか。(ワークシートを適切に指定しないとバグりますが)
Sub Sort_Name_ogawa()
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B2:B317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
End Sub

Sub Sort_No_ogawa()
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A317"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With
End Sub

2020/03/31 05:02

受講生さんのコメント

(コメントID: 6448)

小川様

添削ありがとうございます。
別回答まで頂けて非常に勉強になります。
また、モチベーションも上がりました。

しっかりと見直して自分のものにしたいと思います。
お忙しいところ本当にありがとうございました。
引き続き、精進していきます。

2020/03/31 07:03

小川慶一さんのコメント

(コメントID: 6449)

受講生さん:

お楽しみください☆

2020/03/31 07:11

５倍速！メールマガジン

このメールマガジンの詳細はこちら

受講生の声

たった1ヶ月で人生が劇的に変わりました

佐藤信さん

役員クラスの方から高い評価を受けるようになりました。

佐賀県 - 岩本徹さん

今までまったく知らなかったショートカットキーを使いまくっています。

東京都 - 鷹觜慶さん

年齢60才間近、営業で外回りの時間が多い私でも退社時間が1-2時間程度早くなりました。

東京都 - 宗内隆明さん

受講前もすでにパソコン得意でしたが、そんな私でも受講して本当に良かったと思えた講座です。

東京都 - 佐伯とも子さん

ここまで包括的に仕事に役立つ深い学びを受けれた講座は初めてでした

東京都 - 飯田倫子さん

受講生の声一覧へ

サイト運営者紹介

小川慶一講師/教材/システム開発者紹介

この学習サイトの教材制作、サポート、システム開発をすべてやっています。

より詳しい紹介はこちら