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

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

小川 慶一さんの投稿

(投稿ID: 4517)

受講生の方から、添削依頼を受けました。
以下のものです。
Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

Public 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

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

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

End Sub
Private Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    With Range("B16:K" & Mx)
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlDiagonalDown).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
End Sub
Private Sub P_hani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Private Sub Daimei()
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup

        .CenterHeader = "&F"


        .CenterFooter = "&P / &N ページ"

        .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
            End With
    Application.PrintCommunication = True
    
End Sub
Private Sub Tyousei()
    Keisen
    Daimei
    P_hani
    
End Sub

Public Sub Denpyo()
    Application.ScreenUpdating = False
    Dim wTo As Worksheet
    Dim lnMoto As Long
    Dim lnSaki As Long
    Dim dHiduke As Date
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:" & "B" & wFm.Range("B65536").End(xlUp).Row
    Narabe
       
    For lnMoto = 2 To wFm.Range("B65536").End(xlUp).Row
        If wFm.Range("B" & lnMoto).Value <> wFm.Range("B" & lnMoto - 1).Value Then
            
            If lnMoto > 2 Then
                Tyousei
            End If
            
            lnSaki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & lnMoto).Value
        End If
        dHiduke = wFm.Range("C" & lnMoto).Value
        wTo.Range("B" & lnSaki).Value = Left(Year(dHiduke), 2)
        wTo.Range("C" & lnSaki).Value = Month(dHiduke)
        wTo.Range("D" & lnSaki).Value = Day(dHiduke)
        wTo.Range("E" & lnSaki).Value = wFm.Range("D" & lnMoto).Value
        wTo.Range("F" & lnSaki).Value = wFm.Range("E" & lnMoto).Value
        wTo.Range("H" & lnSaki).Value = wFm.Range("F" & lnMoto).Value
        If wFm.Range("G" & lnMoto).Value > 0 Then
            wTo.Range("I" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        Else
            wTo.Range("J" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        If lnMoto > 2 Then
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value + wTo.Range("K" & lnSaki - 1).Value
        Else
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        lnSaki = lnSaki + 1
    Next
    
    Tyousei
    
    Ireru = "A2:" & "A" & wFm.Range("A65536").End(xlUp).Row
    Narabe
    
    wFm.Range("A2:" & "A" & wFm.Range("A65536").End(xlUp).Row).ClearContents
    wFm.Activate
    Application.ScreenUpdating = True
End Sub

2019/07/01 23:38