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

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

小川 慶一さんの投稿

(投稿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