Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 8.1 Pro : Excel 2007)
ピボット結果を別テーブルに
投稿日時: 17/06/16 09:31:04
投稿者: FILETUBE

 おはようございます。
1つ教えて頂けないでしょうか?
 
ピボットテーブルを作成した後、その結果を別のブックにコピーしたいのですが
マクロの記録で実行しみると
 
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
  Windows("a.xlsm").Activate
  Range("A1:D100").Select
  Application.CutCopyMode = False
  Selection.Copy
 
のSelection.PasteSpecial の部分で実行時エラー1004
ピボットテーブルの一部を移動したり、ワークシートのセル、行、または列を挿入する事はできません
のエラーになります。
 
やりたい事は
 
a.xlsm
 
項目1 項目2 項目3 数量
AA 11 111 100
AA 11 111 200
BB 22 222 300
BB 22 222 400
CC 33 333 500
CC 33 333 600
 
からピボットテーブルを
項目1 項目2 項目3 数量
AA 11 111 300
BB 22 222 700
CC 33 333 1100
 
と作成しその結果を別のブックb.xlsxにコピーしたいのです。
 
b.xlsxは列順が変わっていて
項目3 項目A 項目B 項目2 項目1 数量
111 11 AA 300
222 22 BB 700
333 33 CC 1100
 
としたいのです。
 
 
ピボットテーブル作成まではできるのですが
この後、b.xlsxの別ブックに値をコピーしたいのですが
どのように処理をしていくとよいのかわかる方
おられましたら教えて頂けないでしょうか?
 
下記がピボットテーブル作成までのコードです。
 
Sub Macro3()
 
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R7C4", Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Sheet2!R3C1", TableName:="ピボットテーブル3", DefaultVersion _
        :=xlPivotTableVersion12
    Sheets("Sheet2").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目1")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目2")
        .Orientation = xlRowField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目3")
        .Orientation = xlRowField
        .Position = 3
    End With
     
    ActiveSheet.PivotTables("ピボットテーブル3").AddDataField ActiveSheet.PivotTables( _
        "ピボットテーブル3").PivotFields("数量"), "合計 / 数量", xlSum
    ActiveSheet.PivotTables("ピボットテーブル3").RowAxisLayout xlTabularRow
    Range("C5").Select
     
        
    Dim pv_fld As PivotField
    For Each pv_fld In ActiveSheet.PivotTables(1).PivotFields
        pv_fld.Subtotals(1) = True
        pv_fld.Subtotals(1) = False
    Next pv_fld
         
    Range("A7").Select
    ActiveSheet.PivotTables("ピボットテーブル3").ColumnGrand = False
End Sub
 
 
大変申し訳ありませんが、どうぞよろしくお願いします。
  

回答
投稿日時: 17/06/16 11:15:42
投稿者: sk

引用:
ピボットテーブルを作成した後、その結果を別のブックにコピーしたい

引用:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False

引用:
With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目1")

(標準モジュール)
----------------------------------------------------------------------
Private Sub CopyTable()
 
    Dim pvt As Excel.PivotTable
    Dim ws As Excel.Worksheet
     
    Set pvt = ActiveSheet.PivotTables("ピボットテーブル3")
     
    'ページフィールドを含める場合
    pvt.TableRange2.Copy
    'ページフィールドを除く場合
    'pvt.TableRange1.Copy
     
    Set ws = Workbooks.Add.Worksheets(1)
    ws.Range("A1").PasteSpecial Paste:=xlPasteValues
         
    Set ws = Nothing
    Set pvt = Nothing
 
End Sub
----------------------------------------------------------------------
 
以上のような感じでしょうか。

投稿日時: 17/06/16 13:20:04
投稿者: FILETUBE

  回答ありがとうございます。
初心者にてすいません。
 
どのようにして
b.xlsにピボットの結果を
  
項目3 項目A 項目B 項目2 項目1 数量
111 11 AA 300
222 22 BB 700
333 33 CC 1100
 
のようにコピーしていくのか
もう少し具体的に教えて頂けないでしょうか?
 
どうぞよろしくお願いします。
 

回答
投稿日時: 17/06/16 13:54:28
投稿者: sk

引用:
b.xlsにピボットの結果を
   
項目3 項目A 項目B 項目2 項目1 数量
111 11 AA 300
222 22 BB 700
333 33 CC 1100
  
のようにコピーしていくのか
もう少し具体的に教えて頂けないでしょうか?

コピー元のピボットテーブルにない項目は
貼り付けようがないのではないでしょうか。
 
ピボットテーブル全体の値を b.xls の
任意のワークシート上に貼り付けてから、
そのワークシートの 1 列目と 2 列目の間に
新たな列を 2 列挿入して 1 行目に列見出しとして
"項目A", "項目B" という値を設定したい、
ということでしょうか。
 
また、[項目3],[項目2],[項目1]の 3 つの列の並び順に関しては、
元のピボットテーブル上でそういう並び順になるようにしておいた方が
簡単だと思います。
 
引用:
With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目1")
     .Orientation = xlRowField
     .Position = 1
End With
With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目2")
     .Orientation = xlRowField
     .Position = 2
End With
With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目3")
     .Orientation = xlRowField
     .Position = 3
End With

投稿日時: 17/06/16 14:24:53
投稿者: FILETUBE

  回答ありがとうございます。
 
項目A,項目Bはまた別にブックからデータをセットしたいと思いますので
現段階では未セットのままで構いません。
  
Positionで順番を入れ替えるのは、わかりました。
あとは b.xlsxをOPENして pvt.TableRange2.Copy でしょうか?
 
何度もすいません。
どうぞよろしくお願いします。

回答
投稿日時: 17/06/16 15:08:00
投稿者: sk

引用:
項目A,項目Bはまた別にブックからデータをセットしたいと思いますので
現段階では未セットのままで構いません。

左様で。
 
引用:
Positionで順番を入れ替えるのは、わかりました。
あとは b.xlsxをOPENして pvt.TableRange2.Copy でしょうか?

b.xlsx が新規ブックではなく既存のブックならば、
貼り付け先のワークシートの 1 行目に
既に列見出しが書き込まれているか否か、
もし列見出しが書き込まれている場合、
既に[項目A]と[項目B]が(2, 3列目に)
挿入されている状態であるか否か次第です。
 
ただ空のワークシートに貼り付けるだけなら、
前述のサンプルコードのような
コピーアンドペースト処理を実行なされば
充分でしょう。

投稿日時: 17/06/16 16:20:14
投稿者: FILETUBE

回答ありがとうございます。
 
 Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R7C4", Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Sheet2!R3C1", TableName:="ピボットテーブル3", DefaultVersion _
        :=xlPivotTableVersion12
    Sheets("Sheet2").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目1")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目2")
        .Orientation = xlRowField
        .Position = 2
    End With
    With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目3")
        .Orientation = xlRowField
        .Position = 3
    End With
     
    ActiveSheet.PivotTables("ピボットテーブル3").AddDataField ActiveSheet.PivotTables( _
        "ピボットテーブル3").PivotFields("数量"), "合計 / 数量", xlSum
    ActiveSheet.PivotTables("ピボットテーブル3").RowAxisLayout xlTabularRow
    Range("C5").Select
     
        
    Dim pv_fld As PivotField
    For Each pv_fld In ActiveSheet.PivotTables(1).PivotFields
        pv_fld.Subtotals(1) = True
        pv_fld.Subtotals(1) = False
    Next pv_fld
         
    Range("A7").Select
    ActiveSheet.PivotTables("ピボットテーブル3").ColumnGrand = False
     
'コメント Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'コメント :=False, Transpose:=False
 
     Dim wb As Workbook
     Dim pvt As Excel.PivotTable
     Dim ws As Excel.Worksheet
       
     Set wb = Workbooks.Open("C:\b.xlsx")
     Set pvt = ActiveSheet.PivotTables("ピボットテーブル3")
       
     'ページフィールドを含める場合
     pvt.TableRange2.Copy
         
     Set ws = Workbooks.Add.Worksheets(1)
     ws.Range("A1").PasteSpecial Paste:=xlPasteValues
           
     Set ws = Nothing
     Set pvt = Nothing
 
とコードを書き換えてみました。
 
Set pvt = ActiveSheet.PivotTables("ピボットテーブル3")
の部分でworksheetクラスのPivotTableプロパティを取得できません
のエラーになってしまいます。
 
もう少し教えて頂けないでしょうか?
よろしくお願いします。
 
 

回答
投稿日時: 17/06/16 17:07:56
投稿者: sk

引用:
Set wb = Workbooks.Open("C:\b.xlsx")
Set pvt = ActiveSheet.PivotTables("ピボットテーブル3")

引用:
Set pvt = ActiveSheet.PivotTables("ピボットテーブル3")
の部分でworksheetクラスのPivotTableプロパティを取得できません
のエラーになってしまいます。

b.xlsx を開いたことによって b.xlsx のワークシートが
その時点でのアクティブシートとなったからでは。
 
(そしてそのシート上にありもしない
 [ピボットテーブル3]という名前のピボットテーブルを
 参照しようとするためエラーが発生する)
 
とりあえず、各オブジェクトへの参照が
フォーカス頼みになっているようなコードは
記述なさらないようにされた方がよいでしょう。
 
(標準モジュール)
----------------------------------------------------------------------
Sub Macro4()
 
    Dim wb1 As Excel.Workbook
    Dim ws1 As Excel.Worksheet
     
    Dim wb2 As Excel.Workbook
    Dim ws2 As Excel.Worksheet
     
    Dim pv_cch As Excel.PivotCache
    Dim pv_tbl As Excel.PivotTable
    Dim pv_fld As Excel.PivotField
 
    Set wb1 = ActiveWorkbook 'マクロを実行しているブック自身を指すならば ThisWorkbook の方がよい
    Set ws1 = wb1.Worksheets.Add
     
    Set pv_cch = wb1.PivotCaches.Create(SourceType:=xlDatabase, _
                                        SourceData:="Sheet1!R1C1:R7C4", _
                                        Version:=xlPivotTableVersion12)
     
    Set pv_tbl = pv_cch.CreatePivotTable(TableDestination:=ws1.Range("A3"), _
                                         TableName:="ピボットテーブル3", _
                                         DefaultVersion:=xlPivotTableVersion12)
     
    With pv_tbl
         
        With .PivotFields("項目3")
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields("項目2")
            .Orientation = xlRowField
            .Position = 2
        End With
        With .PivotFields("項目1")
            .Orientation = xlRowField
            .Position = 3
        End With
          
        .AddDataField .PivotFields("数量"), "合計 / 数量", xlSum
        .RowAxisLayout xlTabularRow
             
        For Each pv_fld In .PivotFields
            pv_fld.Subtotals(1) = False
        Next pv_fld
              
        .ColumnGrand = False
  
        Set wb2 = Workbooks.Open("C:\b.xlsx")
        Set ws2 = wb2.Worksheets(1)
        
        .TableRange1.Copy
        ws2.Range("A1").PasteSpecial Paste:=xlPasteValues
            
        Application.CutCopyMode = False
            
    End With
     
    Set pv_fld = Nothing
    Set pv_tbl = Nothing
    Set pv_cch = Nothing
 
    Set ws2 = Nothing
    Set wb2 = Nothing
    Set ws1 = Nothing
    Set wb1 = Nothing
 
End Sub
----------------------------------------------------------------------

回答
投稿日時: 17/06/16 17:20:36
投稿者: sk

補足:

FILETUBE さんの引用:
With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("項目")

sk さんの引用:
With .PivotFields("項目1")

ここでの添え字の半角/全角は明確に区別されますのでご注意下さい。
(原則的にデータソース側の列見出しに合わせること)

投稿日時: 17/06/16 17:34:57
投稿者: FILETUBE

 
本当に何度もありがとうございます。
 
お蔭さまでコピーは出来て、b.xlsxは読み取り専用のままで開いています。
ありがとうございました。
 
またよろしくお願いします。