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

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

受講生さんの投稿

(投稿ID: 3683)

小川先生

お世話になっております。
(2/25に返信をいただいた受講生です。)

先日指摘頂いた内容を修正した上で、
課題の内容を追加しました。

ヘッダーに関しては、"取引先名称"
フッダーに関しては、"シートNo"
上記のような設定内容としました。

添削の方、よろしくお願いします。
Option Explicit

Dim moto As Long    '転記元行番号
Dim saki As Long    '転記先行番号
Public sheet_num As Long   'フッダー用のシート番号

Sub main()  'メインの実行プロシージャ
    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort
    num_del
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)

    Dim w As Worksheet

    For Each w In Worksheets
        Select Case w.Name
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
     
    Range("A2").Value = "1"    'AutoFillによる番号の割り当て
    Range("A2").AutoFill Destination:=Range("A2:A" & LastNum), Type:=xlFillSeries
End Sub
 
Sub name_sort()     '名称で並べ替え
 
    Worksheets("main").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Sub Create_Voucher() 'シート作成用
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")

    sheet_num = 1
     
    For moto = 2 To LastNum
                                     
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                Call header_footer                                       'ヘッダーフッダーの作成を行う
            End If
            saki = 16                                                    '転送先の行番号を初期化する
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
        End If
         
        Call tenki_kingaku
        saki = saki + 1
    Next
    Call keisen                                                  '最終行書込み後、罫線を引く
    Call header_footer                                           'ヘッダーフッダーの作成を行う
End Sub
  
Sub tenki_kingaku()  'データの転記
 
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
 
    Worksheets(Worksheets.Count).Range("B" & saki).Value = Format((shFm.Range("C" & moto).Value), "yy")
    Worksheets(Worksheets.Count).Range("C" & saki).Value = Format(shFm.Range("C" & moto).Value, "m")
    Worksheets(Worksheets.Count).Range("D" & saki).Value = Format(shFm.Range("C" & moto).Value, "d")
    Worksheets(Worksheets.Count).Range("E" & saki).Value = shFm.Range("D" & moto).Value
    Worksheets(Worksheets.Count).Range("F" & saki).Value = shFm.Range("E" & moto).Value
    Worksheets(Worksheets.Count).Range("H" & saki).Value = shFm.Range("F" & moto).Value
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        Worksheets(Worksheets.Count).Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
     
    If saki = 16 Then                                 '残高の記載
        Worksheets(Worksheets.Count).Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("K" & saki).Value = Worksheets(Worksheets.Count).Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
End Sub
 
Sub keisen()  '罫線作成

      With Range("B16:K" & Range("K" & Rows.Count).End(xlUp).Row)
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
      End With
End Sub

Sub header_footer()   '印刷範囲、ヘッダー、フッダーの設定(追加分)
    
    With ActiveSheet.PageSetup
    .PrintArea = "A1:L" & Range("K" & Rows.Count).End(xlUp).Row + 1 '印刷範囲の設定
    .CenterHorizontally = True
    .CenterHeader = "&""明朝""&A"                                   'ヘッダーに取引先名称
    .CenterFooter = "&""ＭＳ Ｐ明朝,標準""&12" & Str(sheet_num)     'フッダーにシート番号
    End With
    
    sheet_num = sheet_num + 1
    
End Sub

Sub num_sort()     'Noで並べ替え
 
    Worksheets("main").Select
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub num_del()     'A列のNoを削除(追加分)

    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Clear
End Sub

2018/02/27 04:27