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

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

らりおさんの投稿

(投稿ID: 4973)

[宿題]　お世話になっております。前回時（第９回）とは別に、もう一度イチから作成しました。追加課題の題意に正しく沿ったものができているかどうかも含めて添削お願い致します。
Option Explicit
Dim wM As Worksheet
Dim wM1 As Worksheet
Dim wAc As Worksheet
Dim w As Worksheet

Dim moTo As Long
Dim saKi As Long
Dim saiGo As Long
Dim Kingaku As Long

Dim HiDuke As Date

Sub denpyosakusei()
    Set wM = Workbooks("s09_homework.xls").Worksheets("main")
    Set wM1 = Workbooks("s09_homework.xls").Worksheets("main1")
    saiGo = wM.Range("B" & wM.Rows.Count).End(xlUp).Row
    
    syokyo
    main1_kairyo
    No
    wM.Range("A1:G" & saiGo).Sort key1:=wM.Range("B1"), Order1:=xlAscending, Header:=xlYes 'B列で並べ替え
    
    For moTo = 2 To saiGo
        HiDuke = wM.Range("C" & moTo).Value
        If wM.Range("B" & moTo).Value <> wM.Range("B" & moTo - 1).Value Then
            saKi = 0
            Kingaku = 0
            wM1.Copy after:=wM
            Set wAc = ActiveSheet
            wAc.Name = wM.Range("B" & moTo).Value
        End If
        With wAc.Range("B16")
            .Offset(saKi).Value = Mid(Year(HiDuke), 3)
            .Offset(saKi, 1).Value = Month(HiDuke)
            .Offset(saKi, 2).Value = Day(HiDuke)
            .Offset(saKi, 3).Value = wM.Range("D" & moTo).Value
            .Offset(saKi, 4).Value = wM.Range("E" & moTo).Value
            .Offset(saKi, 6).Value = wM.Range("F" & moTo).Value
            Select Case wM.Range("G" & moTo).Value
                Case Is > 0
                    .Offset(saKi, 7).Value = wM.Range("G" & moTo).Value
                Case Else
                    .Offset(saKi, 8).Value = wM.Range("G" & moTo).Value
            End Select
            Kingaku = Kingaku + wM.Range("G" & moTo).Value
            .Offset(saKi, 9).Value = Kingaku
        End With
        saKi = saKi + 1
        If wM.Range("B" & moTo).Value <> wM.Range("B" & moTo + 1).Value Then
            With wAc.Range("B16:K" & saKi + 16) '掛線
                .Borders(xlEdgeLeft).Weight = xlThin
                .Borders(xlEdgeBottom).Weight = xlThin
                .Borders(xlEdgeRight).Weight = xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Borders(xlInsideHorizontal).LineStyle = xlDash
            End With
            wAc.PageSetup.PrintArea = "$A$1:$M$" & saKi + 16 '印刷範囲を最終行+1行まで指定
        End If
    Next
    
    No_syokyo
End Sub
Sub main1_kairyo() '追加[1]部分。ヘッダー、フッターをつけて印刷の向きを横に
    With wM1.PageSetup
        .CenterHeader = "&A" 'シート名
        .CenterFooter = "&P" 'ページ数
        .Orientation = xlPortrait
    End With

End Sub

Sub No() 'A列作成
    wM.Range("A2").FormulaR1C1 = "1"
    wM.Range("A3").FormulaR1C1 = "2"
    wM.Range("A2:A3").AutoFill Destination:=wM.Range("A2:A" & saiGo)
    With wM.Range("A1")
        .FormulaR1C1 = "No."
        .Font.Bold = True
        .Interior.ThemeColor = xlThemeColorAccent1
        .Interior.TintAndShade = 0.799981688894314
    End With
End Sub

Sub No_syokyo() '課題[2]部分のA列並べ替え＆消去
    With wM
        .Range("A1:G" & saiGo).Sort key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
        .Range("A1:A" & saiGo).ClearContents
        .Range("A1").Interior.Pattern = xlNone
        .Range("A1").Font.Bold = False
        .Activate
    End With
End Sub

Sub syokyo()
    Application.DisplayAlerts = False
    For Each w In Worksheets
        If InStr(w.Name, "main") = 0 Then
            w.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

2021/01/04 04:51