レッスン-投稿一覧パソコン仕事５倍塾ポータル

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

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

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

マメコトさんの投稿

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

先生のように30分では書けませんでしたが、1時間はかからずに書けました。（ボタンは作りませんでしたけど。）
「とりあえず動く」ものなので、マクロが記録したコードをそのまま使ったりしています。
いかがでしょうか。

2018/08/22 01:56

小川慶一さんのコメント

(コメントID: 5683)

マメコトさん:

添削を返送します。
添付ファイルは無事に受領できていました。

Option Explicit
'Module2は提出時には削除しましょう。
Sub Denpyou()
    Call Sort_First
    Call Delete_Sheets
    Call Create_Denpyou
    Call Sort_End
End Sub

Private Sub Sort_First()
    Dim Ws As Worksheet
    Dim nGyou As Long
    Dim nGyouMx As Long
    
    Set Ws = Worksheets("main")
    Ws.Range("A1").Value = "No"
    nGyouMx = Ws.Range("B" & Rows.Count).End(xlUp).Row
    
    'Autofillを使うことも検討してみてください。
    For nGyou = 2 To nGyouMx
        Ws.Range("A" & nGyou).Value = nGyou - 1
    Next
    
    '↓もうちょいwithでまとめられそう。たとえば、少なくとも[*1]以下はすべて with ws の中に入れられますね。
    Ws.Activate
    Ws.Sort.SortFields.Clear '[*1]
    Ws.Sort.SortFields.Add _
        Key:=Range("B2:B" & nGyouMx), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Ws.Sort
        .SetRange Range("A1:G" & nGyouMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

Private Sub Delete_Sheets()
    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 Create_Denpyou()

    Dim nGyouFm As Long
    Dim nGyouTo As Long
    Dim nGyouFmMx As Long
    Dim nWs As Long
    Dim WsFm As Worksheet
    Dim WsTo As Worksheet
    Dim strDate As String
    Dim strTori As String
    
    nWs = Worksheets.Count
    Set WsFm = Worksheets("main")
    nGyouFmMx = WsFm.Range("B" & Rows.Count).End(xlUp).Row
    
    '[*2], [*3]は重複している部分が多いですね。見本と比べて要再検討です。
    'あるいは、このメールセミナーの第１回から順番にやりなおしてプロセスを体験するのもよいかと。
    For nGyouFm = 2 To nGyouFmMx
        strTori = WsFm.Range("B" & nGyouFm).Value
        strDate = WsFm.Range("C" & nGyouFm).Value
        If strTori <> WsFm.Range("B" & nGyouFm - 1) Then
            Worksheets("main1").Copy after:=Worksheets(nWs)
            Worksheets(nWs + 1).Name = strTori
            nWs = nWs + 1
            Set WsTo = Worksheets(strTori)
            '[*2]
            WsTo.Range("B16").Value = Format(strDate, "yy")                             '日付（年）
            WsTo.Range("C16").Value = Format(strDate, "mm")                             '日付（月）
            WsTo.Range("D16").Value = Format(strDate, "dd")                             '日付（日）
            WsTo.Range("E16").Value = WsFm.Range("D" & nGyouFm).Value                   '会計番号
            WsTo.Range("F16").Value = WsFm.Range("E" & nGyouFm).Value                   '伝票番号
            WsTo.Range("H16").Value = WsFm.Range("F" & nGyouFm).Value                   '摘要
            If WsFm.Range("G" & nGyouFm).Value > 0 Then
                WsTo.Range("I16").Value = WsFm.Range("G" & nGyouFm).Value               '借方金額
            Else
                WsTo.Range("J16").Value = WsFm.Range("G" & nGyouFm).Value * (-1)        '貸方金額
            End If
            WsTo.Range("K16").Value = WsTo.Range("I16").Value - WsTo.Range("J16").Value '残高
            nGyouTo = 17
            If strTori <> WsFm.Range("B" & nGyouFm + 1).Value Then
                Call Add_Keisen
            End If
        Else
            '[*3]
            WsTo.Range("B" & nGyouTo).Value = Format(strDate, "yy")                             '日付（年）
            WsTo.Range("C" & nGyouTo).Value = Format(strDate, "mm")                             '日付（月）
            WsTo.Range("D" & nGyouTo).Value = Format(strDate, "dd")                             '日付（日）
            WsTo.Range("E" & nGyouTo).Value = WsFm.Range("D" & nGyouFm).Value                   '会計番号
            WsTo.Range("F" & nGyouTo).Value = WsFm.Range("E" & nGyouFm).Value                   '伝票番号
            WsTo.Range("H" & nGyouTo).Value = WsFm.Range("F" & nGyouFm).Value                   '摘要
            If WsFm.Range("G" & nGyouFm).Value > 0 Then
                WsTo.Range("I" & nGyouTo).Value = WsFm.Range("G" & nGyouFm).Value               '借方金額
            Else
                WsTo.Range("J" & nGyouTo).Value = WsFm.Range("G" & nGyouFm).Value * (-1)        '貸方金額
            End If
            WsTo.Range("K" & nGyouTo).Value = WsTo.Range("K" & nGyouTo - 1).Value _
                                                + WsTo.Range("I" & nGyouTo).Value _
                                                - WsTo.Range("J" & nGyouTo).Value               '残高
            nGyouTo = nGyouTo + 1
            If strTori <> WsFm.Range("B" & nGyouFm + 1).Value Then
                Call Add_Keisen
            End If
        End If
    Next
End Sub

Private Sub Add_Keisen()
    Dim Gyou As Long
    
    'selection の書き直しについては第１回－第９回までをやりなおす過程で学んでください
    Gyou = Range("E" & Rows.Count).End(xlUp).Row
    Range("B16:K" & Gyou).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
    Range("A1").Select
End Sub

Private Sub Sort_End()
    Dim Ws As Worksheet
    Dim nGyouMx As Long
    
    Set Ws = Worksheets("main")
    nGyouMx = Ws.Range("B" & Rows.Count).End(xlUp).Row
    
    Ws.Activate
    Ws.Sort.SortFields.Clear
    Ws.Sort.SortFields.Add _
        Key:=Range("A2:A" & nGyouMx), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        DataOption:=xlSortNormal
    With Ws.Sort
        .SetRange Range("A1:G" & nGyouMx)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Ws.Range("A1:A" & nGyouMx).ClearContents
End Sub

> 先生のように30分では書けませんでしたが、1時間はかからずに書けました。（ボタンは作りませんでしたけど。）
> 「とりあえず動く」ものなので、マクロが記録したコードをそのまま使ったりしています。
> いかがでしょうか。

2018/08/22 23:44