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

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

受講生さんの投稿

(投稿ID: 3490)

小川先生、いつもお世話になっております。

宿題を投稿します。
罫線に関しては、自動記録のコードを基にネットの情報も参考にテストを繰り返して
不要と思われるコードを削除して仕上げました。
他の方の投稿と先生のコメント、勉強になります。

添削の程、よろしくお願い致します。
Option Explicit
    Dim WOg As Worksheet    '原本シート（main）の変数
    Dim WDa As Worksheet    'データシート(main1)の変数
    Dim WMk As Worksheet    '新規シートの変数
    Dim Ws As Worksheet     '全てのシートを示す変数
    Dim CDaRow As Long      '原本シート（main）の行を示す変数
    Dim CDaMxRow As Long    '原本シート（main）の最終行を示す変数
    Dim CMkRow As Long      '新規シートの行を指定する変数
    Dim SKey As String      'データシートの並び替えを指定する変数
    Dim St As String        'データシートの取引記録に登場する取引先を示す変数
    Dim Dtda As Date        'データシートの日付を示す変数
    
Public Sub Homework()
    Set WOg = Worksheets("main1")
    Set WDa = Worksheets("main")
    CDaMxRow = WDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DeleteDenpyou
    BangouFuri
    
    SKey = "B1"
    Narabikae
    
    CreateDenpyou
    
    SKey = "A1"
    Narabikae
    
    DeleteBangou
End Sub

Private Sub DeleteDenpyou()
    Application.DisplayAlerts = False
    For Each Ws In Worksheets
        Select Case Left(Ws.Name, 4)
            Case "main"
            Case Else
                Ws.delete
        End Select
    Next Ws
    Application.DisplayAlerts = True
End Sub

Private Sub BangouFuri()
    With WDa
        With .Range("A1")
            .Offset(0, 0).Value = "No."
            .Offset(1, 0).Value = .Offset(1, 0).Row
            .Offset(2, 0).Value = .Offset(2, 0).Row
            .Offset(3, 0).Value = .Offset(3, 0).Row
        End With
        .Range("A2:A4").AutoFill Destination:=WDa.Range("A2:A" & CDaMxRow)
    End With
End Sub

Private Sub CreateDenpyou()
    '▼新規シート作成
    CMkRow = 16
    For CDaRow = 2 To CDaMxRow
        If St <> WDa.Range("B" & CDaRow).Value Then
            If CDaRow > 2 Then
                Keisen
            End If
            WOg.Copy after:=Worksheets(Worksheets.Count)
            Set WMk = ActiveSheet
            St = WDa.Range("B" & CDaRow).Value
            WMk.Name = St
            CMkRow = 16
        End If
        Dtda = WDa.Range("C" & CDaRow).Value
        '▼データ転記
        With WMk
            '[1]
            .Range("B" & CMkRow).Value = Format(Dtda, "yy")
            .Range("C" & CMkRow).Value = Format(Dtda, "mm")
            .Range("D" & CMkRow).Value = Format(Dtda, "dd")
            '[2]
            .Range("E" & CMkRow).Value = WDa.Range("D" & CDaRow).Value
            .Range("F" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            .Range("H" & CMkRow).Value = WDa.Range("F" & CDaRow).Value
            '[3]
            If WDa.Range("G" & CDaRow).Value > 0 Then
                .Range("I" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            Else
                .Range("J" & CMkRow).Value = WDa.Range("G" & CDaRow).Value
            End If
            '[4]
            If CMkRow = 16 Then
                .Range("K" & CMkRow).Value = _
                    WorksheetFunction.Sum(.Range("I16:J16"))
            Else
                .Range("K" & CMkRow).Value = _
                    .Range("K" & CMkRow - 1).Value + _
                    WorksheetFunction.Sum(.Range("I" & CMkRow & ":J" & CMkRow))
            End If
        End With
        CMkRow = CMkRow + 1
    Next CDaRow
    Keisen
    WDa.Activate
End Sub

Private Sub Keisen()
    With WMk.Range("B16:K" & CMkRow)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Private Sub Narabikae()
    With WDa.Sort.SortFields
        .Clear
        .Add Key:=WDa.Range(SKey), Order:=xlAscending
    End With
    With WDa.Sort
        .SetRange WDa.Range("A1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    WDa.Activate
    WDa.Range("A1").Activate
End Sub

Private Sub DeleteBangou()
    WDa.Range("A1").EntireColumn.ClearContents
End Sub

2017/10/08 18:38