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

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

のんのんさんの投稿

(投稿ID: 4032)

再提出します。
よろしくお願いします☆

前回の添削で、1か所理解できないところがありました。

「'↓Format関数の活用も検討してください。ogawa」
のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか？
よろしくお願いします。
Option Explicit

Dim Retsu As String

Sub CreateDenpyo()
    Application.ScreenUpdating = False
    NumberingA
    Retsu = "B"
    Sorting
    ExeCreateDenpyo
    Retsu = "A"
    Sorting
    Application.ScreenUpdating = True
End Sub

Sub NumberingA() 'シート"main"のA列に順番に番号を付けて行くマクロ
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    Dim lngGyo As Long
    
    lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Range("A1").Value = "No."
    For lngGyo = 2 To lngMax
        Range("A" & lngGyo).Value = lngGyo - 1
    Next
End Sub

Sub Sorting()
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    
    lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
        Key:=Range(Retsu & "2:" & Retsu & lngMax), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & lngMax)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub

Sub ExeCreateDenpyo()
    'シート"main"のB列のデータの値によって、
    'シート作成(シート"main1"のコピー)、シート名付与、データ転記するマクロ
    
    Dim lngMax As Long  'シート"main"の最大行数を入れる
    Dim st As String    'シート名(取引先名称)を入れる
    Dim lngFm As Long
    Dim lngTo As Long
    Dim shtFm As Worksheet
    Dim shtTo As Worksheet
    
    DeleteDenpyo
    
    Set shtFm = Worksheets("main")
    shtFm.Activate
    lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
    
    For lngFm = 2 To lngMax
        If st <> shtFm.Range("B" & lngFm).Value Then
            If lngFm > 2 Then
                Keisen
            End If
            st = shtFm.Range("B" & lngFm).Value
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)    'コピー
            Set shtTo = ActiveSheet
            shtTo.Name = st 'シート名付与
            lngTo = 16
        End If
        'ここからデータ転記
        shtTo.Range("B" & lngTo).Value = Right(Year(shtFm.Range("C" & lngFm).Value), 2)
        shtTo.Range("C" & lngTo).Value = Month(shtFm.Range("C" & lngFm).Value)
        shtTo.Range("D" & lngTo).Value = Day(shtFm.Range("C" & lngFm).Value)
        shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
        shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
        shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
        If shtFm.Range("G" & lngFm).Value > 0 Then
            shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        Else
            shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
        End If
        
        If lngTo = 16 Then
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
        Else
            shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
        End If
        lngTo = lngTo + 1
    Next
    Keisen
    Worksheets("main").Select
End Sub

Sub DeleteDenpyo()
    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

Sub Keisen()
    Dim lngMax2 As Long
    lngMax2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
    
    ActiveSheet.Range("B16:K" & lngMax2 + 1).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 = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Range("A1").Activate
End Sub

2018/07/26 09:12