Function データ加工_後半()

    '集計加工シートから集計Workシートにコピーして、
    '並べ替えをして、集計して、集計シートに転送している

    Dim r As Long, lngLastRow As Long, lngPasteRow As Long
    Dim i As Long
    Dim KakouSheet As String, SyukeiSheet As String, SyukeiWorkSheet As String
    Dim lngTuki As Long, TargetCol As Long
    Dim strTekiyou As String
    Dim lngGetTekiyou As Long
    
    '加工済みシート
    KakouSheet = ActiveSheet.Name
        
    '----- 設定 開始 -----
    
    '集計処理に使うシート
    SyukeiWorkSheet = "集計WORK"
    
    '集計結果に使うシート
    SyukeiSheet = "集計"
    
    '貼りつけ行を指定
    lngPasteRow = Cells(1, "B").End(xlDown).Offset(1).Row
    
    '----- 設定 終了 -----
        
    Application.ScreenUpdating = False
    
    r = Application.Rows.Count

    '##############
    '#  並べ替え
    '##############
    
    Sheets(SyukeiWorkSheet).Cells.ClearContents
    Sheets(KakouSheet).Activate
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Copy
    
    Sheets(SyukeiWorkSheet).Select
    Cells(lngPasteRow - 1, "B").Select
    ActiveSheet.Paste
    
    Columns("D:E").Select
    Selection.ClearContents
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("B6"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
    
    '##############
    '#   集 計
    '##############

    'シート名から月を求める
    lngTuki = Val(KakouSheet)
    
    '集計シートのターゲット行を求める
    TargetCol = 2 + (lngTuki - 1) * 5

    Sheets(SyukeiWorkSheet).Activate
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    '集計処理
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    
    Sheets(SyukeiWorkSheet).Activate
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    '可視セルのコピー
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
       
    Sheets(SyukeiSheet).Select
    Cells(4, TargetCol).Select
    ActiveSheet.Paste
    Cells(2, TargetCol).Select
    
    Cells.EntireColumn.AutoFit
    
    Sheets(SyukeiWorkSheet).Select
    ActiveSheet.Outline.ShowLevels RowLevels:=3
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    Application.CutCopyMode = False
    Selection.RemoveSubtotal
    Range("A1").Select
    
End Function