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

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

A.Sさんの投稿

(投稿ID: 4385)  添付ファイルのダウンロード権限がありません

小川先生

いつもお世話になっております。
第9回に引き続き、第11回の宿題を提出させていただきます。
お忙しいところ大変恐れ入りますが、添削の程、どうぞよろしくお願い致します。
Sub CreateDenpyo()
    DeleteSheets
    Template_Setup
    Numbering
    Narabekae_Torihikisaki
    Denpyosheet_Set
    Narabekae_No
    NumberingDelete
End Sub

'「main1」シートのページ設定をするマクロ
Private Sub Template_Setup()
    With Sheets("main1").PageSetup
        .PrintArea = "" '印刷範囲の解除
        .CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
        .CenterFooter = "&P" 'フッターに「ページ番号」を挿入
    End With
    Range("A1").Select
End Sub

'「main」シートのA列に番号を振るマクロ
Private Sub Numbering()
    Dim ln As Long
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    ws.Range("A1").Value = "No."
    lnMx = ws.Range("B" & Rows.Count).End(xlUp).Row
    For ln = 2 To lnMx
        ws.Range("A" & ln).Value = ln
    Next
End Sub

'「main」シートのA列のデータを全て削除するマクロ
Private Sub NumberingDelete()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    ws.Range("A1:A" & lnMx).ClearContents
End Sub

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'取引先毎の伝票シートを作成するマクロ
Private Sub Denpyosheet_Set()
    DeleteSheets
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim st As String
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim dt As Date
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Set wsTo = ActiveSheet
            wsTo.Name = st
            lnTo = 16
        End If
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo).Offset(-1).Value
        End If
        dt = wsFm.Range("C" & lnFm).Value
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "m")
        wsTo.Range("D" & lnTo).Value = Format(dt, "d")
        lnTo = lnTo + 1
    Next
    Keisen
End Sub

'取引先名称シートを削除するマクロ
Public Sub DeleteSheets()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 1)
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub

2019/02/13 14:06