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

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

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

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

受講生さんの投稿

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

小川様

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

2019/06/14 15:10

受講生さんのコメント

(コメントID: 6205)

小川様

すみません、コードで囲むのですね。
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

2019/06/14 15:49

小川慶一さんのコメント

(コメントID: 6218)

受講生さん:

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

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

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

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

2019/06/24 20:54

５倍速！メールマガジン

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

受講生の声

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

佐藤信さん

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

佐賀県 - 岩本徹さん

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

東京都 - 鷹觜慶さん

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

東京都 - 宗内隆明さん

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

東京都 - 佐伯とも子さん

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

東京都 - 飯田倫子さん

受講生の声をもっと見る

サイト運営者紹介

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

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

より詳しい紹介はこちら

ショートカットワーク報告

2025年03月26日 22:33

CommaToXls-excel
初回でゴールド賞をとれた！

cat22さん

2025年03月26日 22:12

QuoteToXls-excel
ゴールド賞を達成したこと

cat22さん

2025年03月24日 22:28

QuoteToXls-excel
マイペースでも続いていること

cat22さん

2025年03月19日 20:10

TxtToXls-excel
初回でゴールド賞をとれた！

cat22さん

2025年03月18日 20:52

CommaSpaceToXls
プラチナ賞をとれたこと！

cat22さん

ショートカットワーク報告へ

ショートカットワークコメント

2025年04月16日 08:30

CommaToXls-excel
だいぶ間が空いてしまいました。すみません。実務での活用状況についても報告に含めていただければと …

小川慶一さん

2025年03月18日 09:07

CommaToXls
> エスケープ文字をつけ忘れてうまくいかなくてもあきらめなかったところ「自分ならできる」という…

小川慶一さん

2025年03月18日 09:06

QuoteToXls
> FnとWinキーを押し間違えてウィンドウ表示が変ってしまうところそのこと自体は問題ありませ…

小川慶一さん

2025年03月15日 13:23

TxtToXls
着実に上達されていると感じます (^^

小川慶一さん

2025年02月26日 16:37

TabTo-excel
> Ctrl＋Fn+Shift+End これは大変ですよ。僕も、4キー同時打鍵はしたくありませ…

小川慶一さん

ショートカットワーク一覧へ

コーディングワーク報告

2025年04月02日 21:01

複数の表の間でのマッチング
何も見なくてもスラスラ解けた

cat22さん

2025年04月02日 20:47

複数列の中から、最大値の格納されたセルの情報を出力する
昨日より早くかけたこと

cat22さん

2025年04月02日 20:37

最大値の格納されたセルの情報を出力する
昨日よりスピードがあがった

cat22さん

2025年04月01日 22:03

複数列の中から、最大値の格納されたセルの情報を出力する
動画の真似をしてかけたこと

cat22さん

2025年04月01日 21:27

最大値の格納されたセルの情報を出力する
（１）で類似問題を実施しているので、思ったより早く解けた

cat22さん

コーディングワーク報告へ

コーディングワークコメント

2025年04月16日 08:32

複数の表の間でのマッチング
実務での活用状況どうでしょうか。細かい操作ミスについては気にしないでください。速やかに無意識に修…

小川慶一さん

2025年03月18日 09:10

文字列を加工してデータ転記する(その4)
別のところでも書きましたが、イメージトレーニング大切です。次に出てきたときには瞬時に対応するぞ！…

小川慶一さん

2025年03月18日 09:10

文字列を加工してデータ転記する(その4)
こういうのは慣れです (^^

小川慶一さん

2025年03月18日 09:09

文字列を加工してデータ転記する(その4)
別海も悪いはないです。両方のパターンを自在に使い分けられるようになるとさらによいですね！

小川慶一さん

2025年03月18日 09:06

文字列を加工してデータ転記する(その5)
イメージトレーニングしましょう！

小川慶一さん

コーディングワークへ