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

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

受講生さんの投稿

(投稿ID: 5005)

お世話になります。課題を提出いたします。
第9回でフィードバックをいただいたき、その後練習を重ねた結果、30分で書けるようになりました。
2時間半掛かっていた頃と比べると、頭の負荷が減り、余裕が出てきました。
実務の方でも良い出来事があり、自分の書いたマクロが社内ツール（補助ツールですが）として展開されることになりました。他人に使ってもらうのは初めてで、嬉しさも不安もありますが、「人に喜んでもらえるものを作りたい」という気持ちがより強くなりました。更なるスキルアップを目指します。
Option Explicit
Dim wsFm As Worksheet
Dim lnFmMx As Long
Dim stKey As String
Dim wsTo As Worksheet

Public Sub Sakusei_Button() '「伝票作成」ボタンに割り当て
    Application.ScreenUpdating = False

    Denpyo_Sakujo

    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row

    main_Saiban

    stKey = "B"
    main_Narabekae

    Denpyo_Sakusei
    
    stKey = "A"
    main_Narabekae
    
    main_Saiban_Sakujo
    
    Application.ScreenUpdating = True

    MsgBox ("作成しました。")
End Sub

Public Sub Sakujo_Button() '「伝票削除」ボタンに割り当て
    Denpyo_Sakujo
    MsgBox ("削除しました。")
End Sub

'マクロの記録をしながらテンプレートに以下の設定を実施
'Private Sub main1_Print_Settei()
'    Worksheets("main1").Columns("H:H").ColumnWidth = 14.5
'    Application.PrintCommunication = False
'    With Worksheets("main1").PageSetup
'        .PrintArea = ""
'        .RightHeader = "&D, &T" & Chr(10) & "&A"
'        .CenterFooter = "&P / &N ページ"
'        .Orientation = xlPortrait
'        .FitToPagesWide = 1
'        .FitToPagesTall = False
'    End With
'    Application.PrintCommunication = True
'End Sub

Private Sub main_Saiban()
    wsFm.Range("A1").Value = "No."
    wsFm.Range("A2").Value = "1"
    wsFm.Range("A3").Value = "2"
    wsFm.Range("A2:A3").AutoFill _
        Destination:=wsFm.Range("A2:A" & lnFmMx)
End Sub

Private Sub main_Saiban_Sakujo()
    wsFm.Range("A1:A" & lnFmMx).ClearContents
End Sub

Private Sub main_Narabekae()
    With wsFm.Sort
        With .SortFields
            .Clear
            .Add _
                Key:=wsFm.Range(stKey & "2:" & stKey & lnFmMx), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
        End With
        .SetRange wsFm.Range("A1:G" & lnFmMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Private Sub Denpyo_Sakusei()
    Dim lnFm As Long
    Dim st As String
    Dim lnTo As Long
    Dim dt As Date
    Dim cur As Currency
    
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Denpyo_Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set wsTo = Worksheets("main1 (2)")
            wsTo.Name = st
            lnTo = 16
        End If
        
        dt = wsFm.Range("C" & lnFm).Value
        cur = wsFm.Range("G" & lnFm).Value
        
        With wsTo.Range("B" & lnTo)
            .Value = Format(dt, "yy")
            .Offset(, 1).Value = Format(dt, "mm")
            .Offset(, 2).Value = Format(dt, "dd")
            .Offset(, 3).Value = wsFm.Range("D" & lnFm).Value
            .Offset(, 4).Value = wsFm.Range("E" & lnFm).Value
            .Offset(, 6).Value = wsFm.Range("F" & lnFm).Value
            Select Case cur
                Case Is > 0
                    .Offset(, 7).Value = cur
                Case Else
                    .Offset(, 8).Value = cur
            End Select
            Select Case lnTo
                Case Is = 16
                    .Offset(, 9).Value = cur
                Case Else
                    .Offset(, 9).Value = cur + .Offset(-1, 9).Value
            End Select
        End With
        lnTo = lnTo + 1
    Next
    Denpyo_Keisen
    wsFm.Activate
End Sub

Private Sub Denpyo_Sakujo()
    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 Denpyo_Keisen()
    Dim lnMx As Long
    lnMx = wsTo.Range("B" & Rows.Count).End(xlUp).Row
    With wsTo.Range("B16:K" & lnMx + 1)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub

2021/02/03 08:13