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

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

受講生さんの投稿

(投稿ID: 5507)

小川先生

いつもお世話になっております。
一から書いてみたいので、添削よろしくお願いいたします。
Option Explicit

Dim gst_retu As String

Public Sub main()
    '「main」と[main1]シート以外のワークシートを削除する
    sh_delete
    
    '「No.」の列に番号を割り振る
    shmain_no_assign
    
    '取引先名称で並べ替える
    gst_retu = "B"
    shmain_asc_sort
    
    '取引先名称ごとに伝票を作成する
    denpyo_create

    '「No.」の列を並べ替える
    gst_retu = "A"
    shmain_asc_sort
End Sub

Private Sub shmain_asc_sort()
    Dim wfm_sh As Worksheet
    Dim cfm_mx As Long
    Set wfm_sh = Worksheets("main")
    
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    wfm_sh.Range("A1:G" & cfm_mx).Sort _
        Key1:=wfm_sh.Range(gst_retu & 1), _
        Order1:=xlAscending, _
        Header:=xlYes
End Sub

Private Sub shmain_no_assign()
    Dim wfm_sh As Worksheet
    Dim cfm_gyo  As Long
    Dim cfm_mx As Long
    Set wfm_sh = Worksheets("main")
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    For cfm_gyo = 2 To cfm_mx
        wfm_sh.Range("A" & cfm_gyo).Value = cfm_gyo - 1
    Next
End Sub


Private Sub denpyo_create()
    Dim wfm_sh As Worksheet
    Dim wto_sh As Worksheet
    Dim stfm_torihikisaki As String
    Dim cfm_gyo As Long
    Dim cfm_mx As Long
    Dim cto_cnt As Long
    Dim cfm_kingaku  As Long
    Dim dtfm As Date
    
    Set wfm_sh = Worksheets("main")
    cfm_mx = wfm_sh.Range("B1048576").End(xlUp).Row
    
    For cfm_gyo = 2 To cfm_mx
        If stfm_torihikisaki <> wfm_sh.Range("B" & cfm_gyo).Value Then
            If cfm_gyo > 2 Then
                denpyo_rasenn_draw
            End If
            cto_cnt = 16
            stfm_torihikisaki = wfm_sh.Range("B" & cfm_gyo).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set wto_sh = ActiveSheet
            wto_sh.Name = stfm_torihikisaki
        End If
    
        wto_sh.Range("E" & cto_cnt).Value = wfm_sh.Range("D" & cfm_gyo).Value
        
        wto_sh.Range("F" & cto_cnt).Value = wfm_sh.Range("E" & cfm_gyo).Value

        wto_sh.Range("H" & cto_cnt).Value = wfm_sh.Range("F" & cfm_gyo).Value
        
        dtfm = wfm_sh.Range("C" & cfm_gyo).Value
        
        wto_sh.Range("B" & cto_cnt).Value = Right(Year(dtfm), 2)
        wto_sh.Range("C" & cto_cnt).Value = Month(dtfm)
        wto_sh.Range("D" & cto_cnt).Value = Day(dtfm)
            
        cfm_kingaku = wfm_sh.Range("G" & cfm_gyo).Value
    
        If cfm_kingaku > 0 Then
            wto_sh.Range("I" & cto_cnt).Value = cfm_kingaku
        Else
            wto_sh.Range("J" & cto_cnt).Value = cfm_kingaku
        End If
    
        wto_sh.Range("K" & cto_cnt).Value = wto_sh.Range("K" & cto_cnt - 1).Value + cfm_kingaku
        cto_cnt = cto_cnt + 1
    Next
    denpyo_rasenn_draw
    wfm_sh.Activate
End Sub

Private Sub denpyo_rasenn_draw()
    Dim cto_mx As Long
    cto_mx = Range("K1048576").End(xlUp).Row + 1
      
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    
    End With
    
    With Range("B16" & ":" & "K" & cto_mx).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    
    End With

End Sub


Public Sub sh_delete()
    Dim wks As Worksheet
    Application.DisplayAlerts = False
    
    For Each wks In Worksheets
        If Left(wks.Name, 4) <> "main" Then
            wks.Delete
        End If
        
'Q.下記のような書き方でも[main]を含まないワークシートを削除できましたが、これもありですか？
'       If InStr(wks.Name, "main") = 0 Then
'           wks.Delete
'       End If
    Next
    Application.DisplayAlerts = True
End Sub

2023/12/12 21:13