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

小川先生
お世話になっております。
10月末から勉強させていただいております。
複数シート間で処理をするときのプログラムの書き方がまだしっかりと身についていません。
また変数名を何にするか決めるのに時間がかかり決めた変数名に自信が持てません。
引き続き身につくよう勉強していきます。
読みにくいコードとなり申し訳ありませんがご確認お願いいたします。
Sub denpyoMake()
'mainシートの取引先名称ごとにシートを分ける

    Dim shFm As Worksheet
    Dim shTo As Worksheet
    Dim sortMaeNum As Long
    Dim sortMaeNumMx
    Dim lnfm As Long
    Dim lnfmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    
    'main、main1以外のシートを削除
    deleteSheet
    
    sortMaeNumMx = Range("B" & Rows.Count).End(xlUp).Row
    For sortMaeNum = 2 To sortMaeNumMx
        shFm.Range("A" & sortMaeNum).Value = sortMaeNum - 1
    Next sortMaeNum
    
    'mainシートでソートする
    sortTorihiki
    
    lnfmMx = Range("B" & Rows.Count).End(xlUp).Row
    For lnfm = 2 To lnfmMx
        If shFm.Range("B" & lnfm).Value <> shFm.Range("B" & lnfm - 1).Value Then
            If lnfm <> 2 Then
                '罫線を引く
                keisenDraw (lnTo)
            
                '印刷範囲を設定する
                printSetting (lnTo)
            End If
            
            Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shFm.Range("B" & lnfm).Value
            Set shTo = ActiveSheet
            shTo.Range("F2").Value = shTo.Name
            lnTo = 16
        Else
            lnTo = lnTo + 1
        End If
        dt = shFm.Range("C" & lnfm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnfm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnfm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnfm).Value
        If shFm.Range("G" & lnfm).Value > 0 Then
            shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnfm).Value
        Else
            shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnfm).Value
        End If
        shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + shFm.Range("G" & lnfm).Value
            
    Next lnfm
    
    'mainシートを元の順番でソートする
    sortMotojun

    shFm.Activate
    shFm.Range("A1").Select
    
End Sub

Private Sub sortTorihiki()
'取引先名称で並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No"
End Sub

Private Sub sortMotojun()
'元の並び順に並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A:A").ClearContents
End Sub

Private Sub deleteSheet()
' main、main1以外のシートを削除する

    Application.DisplayAlerts = False
    Dim sh As Worksheet
    For Each sh In Worksheets
        If Left(sh.Name, 4) <> "main" Then
            sh.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub keisenDraw(mxGyo As Long)
'追加シートに罫線を引く

    With Range("B16:K" & mxGyo)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub printSetting(maxGyo As Long)
'印刷範囲を変更する。またヘッダ・フッタを入れる。

Range("A1:L" & maxGyo).Select
    ActiveSheet.PageSetup.PrintArea = "A1:L" & maxGyo + 1
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&A"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 10
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

2016/11/23 03:18