マクロを使ってピポットを実行したい

質問

マクロを使ってピポットを実行したい
下記に書いたのが自動作成したものですが、なぜか実行すると画像の様になります。
そして、毎回実行する行数は違います、違う行数でもできるようにできたら尚すんばらしいです。

月一回作成する資料で、担当者別に作成します。だいた、３０人ぐらいですが…
ボタンクリックでできる様にしたいのでマクロを使ってます。

Sub ピポット実行()
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Sheet1!C1:C7").CreatePivotTable TableDestination:="", TableName:= _
"ピボットテーブル1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("ピボットテーブル1").AddFields RowFields:=Array("担当者名", _
"得意先2", "メーカー名"), ColumnFields:="売上年月"
With ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("売上金額")
.Orientation = xlDataField
.Caption = "合計 / 売上金額"
.Function = xlSum
End With
ActiveWorkbook.ShowPivotTableFieldList = True
End Sub

なにとぞよろしくお願いいたします

まったく同じ資料に実行をする場合は、大丈夫なのですが、少しでも違う資料にするとだめになります。
ピポットの形になっても、絶対に合計でできなかったり(個数などになったりしてします。)

回答No.2

end-u · ベストアンサー

すみません、#1で画像を添付し損ねました。

ついでですが。
項目を変動させて柔軟な集計ができるのがPivotTableの長所なので、マクロで固定しなくても良いのになぁ、と思います。
集計方法を変えたり書式を設定したりするのが面倒な場合は、そこをマクロにしてあげればいいのではないかと。

例として、選択したデータフィールドを合計にして書式を設定するサンプル。
Sub try()
　　Dim r As Range, x

　　If TypeName(Selection) = "Range" Then
　　　　For Each r In Selection
　　　　　　On Error Resume Next
　　　　　　x = r.PivotField.Calculation
　　　　　　On Error GoTo 0
　　　　　　If Not IsEmpty(x) Then
　　　　　　　　With r.PivotField
　　　　　　　　　　.Function = xlSum
　　　　　　　　　　.NumberFormat = "#,##0_ ;[red]-#,##0 "
　　　　　　　　　　.Caption = .SourceName & " 計"
　　　　　　　　End With
　　　　　　　　x = Empty
　　　　　　End If
　　　　Next
　　End If
End Sub

回答No.1

end-u

行数が違っても、データ項目名が不変であれば

Sub try1()
　　Dim Source As Range 'データ範囲を格納する変数
　　Dim pvt　　As PivotTable

　　'データ範囲がA1セルを起点として連続範囲である事
　　Set Source = ActiveSheet.Range("A1").CurrentRegion
　　Set pvt = ActiveWorkbook.PivotCaches.Add( _
　　　　　　　　　　　　　　 SourceType:=xlDatabase, _
　　　　　　　　　　　　　　 SourceData:=Source.Address(External:=True) _
　　　　　　　　　　　　　　 ).CreatePivotTable(TableDestination:="")
　　pvt.AddFields RowFields:=Array("担当者名", "得意先2", "メーカー名"), _
　　　　　　　　　ColumnFields:="売上年月"
　　With pvt.PivotFields("売上金額")
　　　　.Orientation = xlDataField
　　　　.Caption = "合計 / 売上金額"
　　　　.Function = xlSum
　　End With
　　ActiveWorkbook.ShowPivotTableFieldList = True

　　Set pvt = Nothing
　　Set Source = Nothing
End Sub

..こんな感じで処理できます。A1セル起点でデータ範囲が連続している事が条件です。

データ項目名が変わる場合は、行フィールド、列フィールド、データフィールドの判定ができないので自動というわけにはいきません。
逆に、フィールド設定の判定ができればいいですけど。
例えば画像のように、データの起点がA2セルからで、1行目に判定文字を入れるとか。
（r：行フィールド、c：列フィールド、d：データフィールド）

Sub try2()
　　Dim Chkrng As Range
　　Dim Source As Range
　　Dim r　　　As Range
　　Dim pvt　　As PivotTable

　　With ActiveSheet.Range("A1").CurrentRegion
　　　　Set Chkrng = .Rows(1).Cells
　　　　Set Source = Intersect(.Cells, .Offset(1))
　　End With
　　Set pvt = ActiveWorkbook.PivotCaches.Add( _
　　　　　　　　　　　　　　 SourceType:=xlDatabase, _
　　　　　　　　　　　　　　 SourceData:=Source.Address(External:=True) _
　　　　　　　　　　　　　　 ).CreatePivotTable(TableDestination:="")
　　For Each r In Chkrng
　　　　Select Case StrConv(r.Value, vbNarrow + vbLowerCase)
　　　　Case "r"
　　　　　　pvt.PivotFields(r.Offset(1).Value).Orientation = xlRowField
　　　　Case "c"
　　　　　　pvt.PivotFields(r.Offset(1).Value).Orientation = xlColumnField
　　　　Case "d"
　　　　　　With pvt.PivotFields(r.Offset(1).Value)
　　　　　　　　.Orientation = xlDataField
　　　　　　　　.Caption = r.Offset(1).Value & " 計"
　　　　　　　　.Function = xlSum
　　　　　　End With
　　　　End Select
　　Next
　　ActiveWorkbook.ShowPivotTableFieldList = True

　　Set pvt = Nothing
　　Set Chkrng = Nothing
　　Set Source = Nothing
End Sub