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

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

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

小川慶一さんの投稿

(投稿ID: 4511)

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

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

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

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

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

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

End Sub
Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    Range("B16:K" & Mx).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("B16:K" & Mx).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("B16:K" & Mx)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub
Sub Phani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Sub Daimei()
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

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

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

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

'↓Excellent v(^^*
Sub WsDelete()
    Dim wd As Worksheet
    Application.DisplayAlerts = False
    For Each wd In Worksheets
        If Left(wd.Name, 4) <> "main" Then
            wd.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

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

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

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

Sub Daimei()
    '不要と思しきものがかなりありますね。ご自身で設定したものを見出し、それ以外は積極的に削除を！
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

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

2019/06/24 22:55

小川慶一さんのコメント

(コメントID: 6219)

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

2019/06/24 22:56

５倍速！メールマガジン

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

受講生の声

たった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)
イメージトレーニングしましょう！

小川慶一さん

コーディングワークへ