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

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

受講生さんの投稿

(投稿ID: 4855)

小川さん　いつもお世話になっております。

下記課題を提出します。添削のほどよろしくお願いいたします。

追記:
A列のデータを初期化するやり方はわかりましたが、課題1の印刷設定がいまいちわかりませんでした。
とりあえず、googleで調べながらヘッダーにシート名、ヘッダーに番号を挿入、といった設定をしました。
Option Explicit
'全体処理
Sub Main()
    Denpyyo_Delete
    Print_Set
    No_Add
    Torihikisaki_Asccending_Order
    Denpyo_Create
    No_Asccending_Order
    No_Delete
End Sub

'取引先毎に伝票作成
Sub Denpyo_Create()
    Denpyyo_Delete
    Dim WFm As Worksheet
    Dim WTo As Worksheet
    Dim CFm As Long
    Dim CFmMax As Long
    Dim CName As String
    Dim CSum As Long
    Dim Cnt As Long
    Dim Dt As Date
    Set WFm = Worksheets("main")
    CFmMax = WFm.Range("B65536").End(xlUp).Row
    Cnt = 16
    
    For CFm = 2 To CFmMax
        If CName <> WFm.Range("B" & CFm).Value Then
            If CFm <> 2 Then
                Denpyo_DrawLine
            End If
            
            Cnt = 16
            CName = WFm.Range("B" & CFm).Value
            Sheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = CName
            Set WTo = ActiveSheet
        End If
            
        WTo.Range("H" & Cnt).Value = WFm.Range("F" & CFm).Value
        WTo.Range("E" & Cnt).Value = WFm.Range("D" & CFm).Value
        WTo.Range("F" & Cnt).Value = WFm.Range("E" & CFm).Value
                
        Dt = WFm.Range("C" & CFm).Value
        
        WTo.Range("B" & Cnt).Value = Right(Year(Dt), 2)
        WTo.Range("C" & Cnt).Value = Month(Dt)
        WTo.Range("D" & Cnt).Value = Day(Dt)
        
        CSum = WFm.Range("G" & CFm).Value
        If CSum < 0 Then
            WTo.Range("J" & Cnt).Value = CSum
        Else
            WTo.Range("I" & Cnt).Value = CSum
        End If
        WTo.Range("K" & Cnt).Value = WTo.Range("K" & Cnt - 1).Value + CSum
        Cnt = Cnt + 1
    Next
    Denpyo_DrawLine
    
End Sub
'mainシートのNoを追加
Sub No_Add()
    Dim WFm As Worksheet
    Dim CFmMax As Long
    Set WFm = Worksheets("main")
    CFmMax = WFm.Range("B65536").End(xlUp).Row
    
    WFm.Range("A1").Value = "No"
    WFm.Range("A2").FormulaR1C1 = "1"
    WFm.Range("A3").FormulaR1C1 = "2"
    WFm.Range("A2:A3").AutoFill Destination:=WFm.Range("A2:A" & CFmMax)
End Sub
'取引先名称を昇順
Sub Torihikisaki_Asccending_Order()
    Dim WFm As Worksheet
    Dim CFmMax As Long
    Set WFm = Worksheets("main")
    CFmMax = WFm.Range("B65536").End(xlUp).Row
    
    WFm.Range("A1:G" & CFmMax).Sort _
    Key1:=WFm.Range("B1"), _
    Order1:=xlAscending, _
    Header:=xlYes

End Sub
'NOを昇順
Sub No_Asccending_Order()
    Dim WFm As Worksheet
    Dim CFmMax As Long
    Set WFm = Worksheets("main")
    CFmMax = WFm.Range("B65536").End(xlUp).Row
    
    WFm.Range("A1:G" & CFmMax).Sort _
    Key1:=WFm.Range("A1"), _
    Order1:=xlAscending, _
    Header:=xlYes
End Sub

'伝票を削除
Sub Denpyyo_Delete()
    Dim Wks As Worksheet
    Application.DisplayAlerts = False
    
    For Each Wks In Worksheets
        If Left(Wks.Name, 4) <> "main" Then
            Wks.Delete
        End If
    Next Wks
    
    Application.DisplayAlerts = True

End Sub

'　課題2 A列のデータ全て削除
Sub No_Delete()
    Dim WFm As Worksheet
    Set WFm = Worksheets("main")
    WFm.Columns("A:A").ClearContents

End Sub
'伝票の線を引く
Sub Denpyo_DrawLine()
    Dim CFmMax As Long
    CFmMax = ActiveSheet.Range("B65536").End(xlUp).Row
    
    With Range("B16:K" & CFmMax).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("B16:K" & CFmMax).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("B16:K" & CFmMax).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("B16:K" & CFmMax).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("B16:K" & CFmMax).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("B16:K" & CFmMax).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
End Sub

'課題[1] プリンター設定のみ
'シート毎に設定すると手間がかかるので最初の型sheet(main1)にて印刷形式を設定
Sub Print_Set()
 
    '印刷設定
    With Worksheets("main1").PageSetup
        .PrintArea = "B:K"  '印刷範囲の設定
        .Zoom = False       '倍率をクリア
        .FitToPagesWide = 1 '横方向に1ページに収める
        .FitToPagesTall = 1 '縦方向に1ページに収める
        .Orientation = xlPortrait  '印刷:縦向き
        .CenterHeader = "&B&A&20"  '中央ヘッダーにsheet名と同じ名前を記載
        .RightHeader = "&D"  '右ヘッダーへ当日日付
        .CenterFooter = "-　" & "&P" & "　-"  'フッターの設定
    End With
    
    '印刷プレビュー
    'Worksheets("main1").PrintPreview
End Sub

2020/09/14 03:33