■ExcelVBAで複数条件で抽出して表を作成

ExcelVBAで複数条件で抽出して表を作成 - 教えて！goo
一応、次のステップ書いておいたんだけど〆られたのでscrapいき。 :)

Option Explicit

Sub pre() 'とりあえずサンプルデータBookを作ってみる
　　Const x = 10
　　Const y = 10000

　　With Workbooks.Add.Sheets(1)
　　　　.Range("A1:D1").Value = [{"広域","地域","性別","年代"}]
　　　　.Range("A2").Resize(y).Formula = "=INT(B2/100)"
　　　　.Range("B2").Resize(y).Formula = "=INT(RAND()*1000)+100"
　　　　.Range("C2").Resize(y).Formula = "=INT(RAND()*2)+1"
　　　　.Range("D2").Resize(y).Formula = "=INT(RAND()*13)*10/2+40"
　　　　.Range("E1").Resize(, x).Formula = "=COLUMN(A1)"
　　　　.Range("E2").Resize(y, x).Formula = "=INT(RAND()*10)"
　　　　.Range("A1").CurrentRegion.Copy
　　　　.Range("A1").PasteSpecial xlPasteValues
　　End With
　　Application.CutCopyMode = False
End Sub

（pre実行後）


'新規にできたBook.Sheet1がActiveになっている事を確認してそのまま下のコードを実行。

Sub try() 'サンプルデータBookをActiveにして実行
　　Dim w As Worksheet
　　Dim r As Range
　　Dim p As PivotTable
　　Dim s As String
　　Dim i As Long

　　Application.ScreenUpdating = False
　　With ActiveWorkbook
　　　　Set r = .ActiveSheet.Range("A1").CurrentRegion
　　　　Set p = .PivotCaches.Add(SourceType:=xlDatabase, _
　　　　　　　　　　　　　　　　 SourceData:=r).CreatePivotTable("")
　　End With
　　p.AddFields RowFields:=Array("地域", "性別", "年代"), _
　　　　　　　　ColumnFields:="data", _
　　　　　　　　PageFields:="広域"
　　For i = 5 To r.Columns.Count
　　　　p.AddDataField p.PivotFields(i), , xlSum
　　　　s = s & "+'" & p.PivotFields(i).Name & "'"
　　Next
　　p.CalculatedFields.Add("k", "=" & Mid(s, 2)).Orientation = xlDataField
　　p.PivotFields("年代").ShowAllItems = True
　　With p.PivotFields("性別")
　　　　.PivotItems("1").Caption = "男性"
　　　　.PivotItems("2").Caption = "女性"
　　　　.ShowAllItems = True
　　End With
　　p.NullString = "0"

　　'Pivotを新規Bookへ移動
　　ActiveSheet.Move
　　Set p = ActiveSheet.PivotTables(1)

　　'Pagesを各Sheetに展開
　　p.ShowPages PageField:="広域"
　　For Each w In ActiveWorkbook.Worksheets
　　　　For Each p In w.PivotTables
　　　　　　Set r = Intersect(p.RowRange, w.Columns("A:B"))
　　　　　　'Pivot解除
　　　　　　With p.TableRange2
　　　　　　　　.Copy
　　　　　　　　.PasteSpecial xlPasteValues
　　　　　　　　.ClearFormats
　　　　　　End With
　　　　　　r.SpecialCells(xlCellTypeBlanks) _
　　　　　　 .FormulaR1C1 = "=if(right(r[-1]c,1)=""計"","""",r[-1]c)"
　　　　　　r.Value = r.Value
　　　　Next
　　Next
　　Application.ScreenUpdating = True
End Sub

（try実行後）


'要は、面倒な作業をExcelの基本機能に任せて
'仕上げとしてVBAで加工、体裁を整えるようにしたらいかがでしょう、という案でした。