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

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

受講生さんの投稿

(投稿ID: 2792)

小川先生、いつもお世話になっております。
印刷範囲とヘッダーを追加した伝票作成マクロの作成を致しました。

モジュールレベルの変数とプロシージャレベルの変数をうまく使い分けることがまだ難しいように感じました。
添削の程、何卒よろしくお願いします。
Option Explicit
Dim Mn As Worksheet
Dim Mn1 As Worksheet
Dim Amax As Long
 
Sub Denpyo_making()
    Set Mn = Worksheets("main")
    Set Mn1 = Worksheets("main1")
    Amax = Mn.Range("B65536").End(xlUp).Row
    
    Deletesheets1
    Numbering
    Narabikae
    sheets_making
    Narabikae2
    syuseiH_C

End Sub

Sub Deletesheets1()
    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 Numbering()

    Mn.Range("A2").Value = 1
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries

End Sub

Sub Narabikae()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("B1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A1:G" & Amax)
        .Header = xlYes
        .Apply
    End With
End Sub

Sub sheets_making()
    Dim Namae As String
    Dim gyo As Long
    Dim Nws As Worksheet
    Dim dt As Date '日付
    Dim saki As Long
    
    For gyo = 2 To Amax
        If Namae <> Mn.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen_making '最初だけ罫線回避
            End If
            Namae = Mn.Range("B" & gyo).Value
            Sheets("main1").Copy After:=Sheets(Sheets.Count)
            Sheets("main1 (2)").Select
            Sheets("main1 (2)").Name = Namae
            Set Nws = Worksheets(Namae)
            saki = 16
        End If

        dt = Mn.Range("C" & gyo).Value
        Nws.Range("B" & saki).Value = Right(Year(dt), 2)
        Nws.Range("C" & saki).Value = Month(dt)
        Nws.Range("D" & saki).Value = Day(dt)
        Nws.Range("F2").Value = Mn.Range("B" & gyo).Value
        Nws.Range("E" & saki).Value = Mn.Range("D" & gyo).Value
        Nws.Range("F" & saki).Value = Mn.Range("E" & gyo).Value
        Nws.Range("H" & saki).Value = Mn.Range("F" & gyo).Value
        
        If Mn.Range("G" & gyo).Value > 0 Then
            Nws.Range("I" & saki).Value = Mn.Range("G" & gyo).Value
        Else
            Nws.Range("J" & saki).Value = Mn.Range("G" & gyo).Value
        End If
        Nws.Range("K" & saki).Value = Nws.Range("I" & saki).Value + Nws.Range("J" & saki).Value
        saki = saki + 1
    Next
    keisen_making '最後の会社のシートに罫線つける
End Sub

 Sub keisen_making()
    Dim cNewmax
    cNewmax = Range("B65536").End(xlUp).Row
    Range("B16:K" & cNewmax).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
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Sub Narabikae2()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("C1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A2:G" & Amax)
        .Header = xlYes
        .Apply
    End With
    Mn.Range("A2").Value = ""
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
    
End Sub
    
Sub syuseiH_C()
    Dim cNewmax As Long
    Dim c As Long
    Dim Wh As Worksheet
    cNewmax = Range("B65536").End(xlUp).Row
    
    For Each Wh In Worksheets
        If Left(Wh.Name, 4) <> "main" Then
            With Wh.PageSetup
                .LeftHeader = Wh.Name
                .RightHeader = "&D"
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
            End With
            ActiveSheet.PageSetup.PrintArea = "A1:K" & cNewmax
        End If
    Next
End Sub

2017/01/22 08:29