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

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

受講生さんの投稿

(投稿ID: 4737)

お世話になっております。
伝票作成マクロを一通り受講したのち、一から記憶を頼りに作成してみました。
挙動については問題なかったので、あとは不必要な部分やセオリーに反している部分があればご指摘いただけると幸いです。
なお一点、並び替えマクロ（プロシージャ名：sorting)にて自動記述後取捨選択箇所の判断がつかずそのまま活用している為（セミナー内に記載されていた例と同じコードが自動で書かれなかったので・・・）、不要な部分とその判断方法をご教示頂けたら嬉しいです。
Option Explicit

Dim G_retu As String
Public Sub main()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    sheetDelete
    
    writeNo
    
    G_retu = "B"
    sorting
    
    sheetcreat

    G_retu = "A"
    sorting
    
    Aclear
    Worksheets("main").Select
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


Public Sub sheetDelete()
    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 writeNo()
    Dim ws As Worksheet
    Dim lnFmMx As Long
    Dim ln As Long
    
    Set ws = Worksheets("main")
    lnFmMx = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    For ln = 2 To lnFmMx
        ws.Range("A" & ln).Value = ln - 1
    Next
End Sub
    
    
Private Sub sorting()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    Range(G_retu & "1").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Range(G_retu & "1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A2:G" & lnMx)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub


Private Sub sheetcreat()
    Dim shFm As Worksheet
    Dim shTo As Worksheet
    
    Dim lnFm As Long
    Dim lnFmMx As Long
    
    Dim lnTo As Long
    
    Dim strName As String
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If strName <> shFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                keisen
            End If
            strName = shFm.Range("B" & lnFm).Value
            Debug.Print strName
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = strName
            lnTo = 16
        End If
        dt = shFm.Range("C" & lnFm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnFm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnFm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnFm).Value
        
        Select Case shFm.Range("G" & lnFm).Value
            Case Is > 0
                shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
            Case Else
                shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
        End Select
        If lnTo = 16 Then
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
        Else
            shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
        End If
        
        lnTo = lnTo + 1
    Next
    keisen
End Sub

Private Sub keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    Range("B16:K" & lnMx).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

Private Sub Aclear()
    Dim lnMx
    lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
    Debug.Print lnMx
    Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub

2020/05/23 23:54