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