ExcelVBAで複数条件で抽出して表を作成 - 教えて!goo
一応、次のステップ書いておいたんだけど〆られたのでscrapいき。 :)
一応、次のステップ書いておいたんだけど〆られたので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で加工、体裁を整えるようにしたらいかがでしょう、という案でした。