[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートのコピーからブック保存まで』（ときま）
下記のようなことがしたく、マクロの記録でやってみましたが、コードが多いので、シンプルにVBAでやる方法がありますか？
特に3.の処理が組み立てられません。
1.ピボットテーブル表のあるsheet1とsheet2のコピーを新規ブックで作成し、
2.新規ブックで作成したピボットテーブル表を値複写と書式複写で単なる表にし、
3.また、単なる表にする際、sheet2のピボットテーブル表は一つ目の行フィールド
で5つあるアイテムを一つずつフィルターをかけてから単なる表にしたい。
つまり、sheet1及びsheet2(アイテムAでフィルターかけたもの)sheet1及びsheet2(アイテムBでフィルターかけたもの)のように5つ新規ブックを作りたい。
4.最後に5つのブックのブック名をA〜Eでデスクトップに保存する。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
おはようございます ＾＾ https://www.relief.jp/docs/excel-vba-filter-pivot-table.html など、参考になるかと。。。私、ピボットあまり知らないので。。 単なる表にしてから、必要な物だけ取り込む！＾＾；みたいな事も 一案かも。。。お詳しい方の回答をお待ちくださいね。。。でわ。 m(_ _)m （隠居じーさん） 2020/08/17(月) 07:31
?Aコピー元はピボットテーブルなのですが、コピー先は見た目が同じのただの表にしたいのですが、値コピーになるみたいでどう修正したらよいでしょうか？
?B下記コードはA部署のみですが、他にB〜F部署まで作りたいのですが、コードを単純にできないでしょうか？
Dim 場所 As String
場所 = CreateObject("WScript.Shell").SpecialFolders("Desktop")
With ThisWorkbook
.Sheets(Array(3, 4)).Copy
On Error Resume Next
With ActiveWorkbook
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("職員区分")).Select
Selection.Cut
ActiveSheet.Buttons.Delete
Sheets("明細").Select
Dim itm As PivotItem
For Each itm In ActiveSheet.PivotTables("P_明細").PivotFields("部署").PivotItems
Select Case itm.Value
Case A
itm.Visible = True
Case Else
itm.Visible = False
End Select
Next itm
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("職員区分")).Select
Selection.Cut
ActiveSheet.Buttons.Delete
.SaveAs Filename:=場所 & "\総括表(A部).xlsx"
.Close
End With
On Error GoTo 0
.Activate
End With
（ききく） 2020/08/18(火) 15:39
こんにちは ＾＾
↑ で 動作しているなら。。。＾＾；
１．保存時、ファイルフォーマット［51］を指定してみてください
２．XlPasteTypeを
xlPasteAll -4104
に変えるといいですよ。
３．コピペ処理が、ループからもれているのでは
select句要るのかなぁ？やっていないので解りませんが。＾＾；
コード全体の件は、相済みませんが、当方でテスト出来る環境に御座いませんので
現状では何とも。。。各シートのセル番地が解る情報を教えて頂けると［違いが判る
ダミー情報で］お手伝い出来るかもしれません。ちょっと見では。。一気に新規ブック
作成すると、片方しかアクティブにはならないので、もう少し丁寧なロジックが必要
かもしれませんね。保存先パス取得も問題あるかも？。。。ピボットにお詳しい方の
回答をお待ちくださいませ。m(_ _)m
（隠居じーさん） 2020/08/18(火) 17:12
追伸 ＞＞保存先パス取得も問題あるかも？。。。 有りませんでした。。。済みません。m(_ _)m ピボット、作ってみます。←勉強しなおそう。(￣▽￣) m(_ _)m （隠居じーさん） 2020/08/18(火) 17:36
（マナ） 2020/08/18(火) 18:30
マナさん
失礼しました。
コピーする2つのシートの名前は、「総括表」と「明細表」です。
レイアウトですが、2つとも、1行目にタイトルがあり、2行目はP2セルとS2セルに文字が入力されています。
3行目以降が、B3：S30の範囲でピボットテーブル表（ピボットテーブル名：P_総括表）があり、スライサー機能によりフィルターをかけています。
また、フォームコントロールのボタンを1つ設置しています。
なお、両方のシートともアクティブにした際、自動でピボットテーブルが更新されるようVBAを組んでいます。
明細シートの方はピボットテーブル名がP_明細でB3：U138の範囲にあります。（行数が変動する）
マクロの記録も活用しながらコードを作ったので自分でも汚いコードなんだろうなと思っております。
やりたいことは、シートの「総括表」と「明細」を各部（5部署）に配るため、「明細」シートを該当部署だけに絞り、5部署分のExcelファイルを自動で作りたいです。その際ピボットテーブル形式ではなく単なる表で配りたいです。
（ときま） 2020/08/18(火) 21:54
（マナ） 2020/08/18(火) 22:47
１）新規ブック作成（シート数２）
２）総括表ピボットを新規ブックにコピー（※）
３）明細ピボットで、部署Aでフィルター
４）明細ピボットを新規ブックにコピー（※）
５）新規ブックを名前を付けて保存
６）３）〜５）すねての部署で繰り返し
（※）ピボットをコピーするとき、
ヘッダー部分とデータ部分の２回に分けてコピペ
（マナ） 2020/08/19(水) 08:19
こんにちは ＾＾
自身のお勉強で作成してみました。。。恐怖の憶測と推測のデモンストレーションコード ＾＾；
回答とは程遠いやもしれませんが。ご考察の足しにでも、。。。ならなければポイしておいて下さいませ。
Sheet1にダミーを作成後それを使用してピボットを作成し、項目毎の集計表を保存しました。
とある、フォルダに 新規ブックを作成後、IJ00090.xlsm で保存して
お試しを。同フォルダ内に、ご希望に近いものが作成されているかも。。。(￣▽￣)。。。m(_ _)m
自信はありません、かるーぃ考えのじ〜さんが、ルンルン！コードでも書くか。。。的に作っていま
すので、ちょい参考程度にお止めおきくださいませ。でわ
Option Explicit
Sub OneInstanceMain()
Const zProgramID As String = "IJ00090.xlsm"
Dim ztb As Workbook
Dim zWb As Workbook
Dim i As Long
Dim pvt As PivotField
Dim zWs As Worksheet
Dim t As Double
t = Timer
Set ztb = Workbooks(zProgramID)
zDummyDtaMake ztb
PvMake ztb
Set zWs = ztb.Worksheets("ztmpxxij")
Worksheets.Add
ActiveSheet.Name = "IJjejeje"
Set pvt = ztb.Worksheets("ztmpxxij").PivotTables("P_明細").PivotFields("部署")
Application.DisplayAlerts = False
With pvt
For i = 1 To .PivotItems.Count
.ClearAllFilters
.CurrentPage = .PivotItems(i).Name
Worksheets("IJjejeje").Copy
Set zWb = ActiveWorkbook
With zWb.ActiveSheet
zWs.Cells(3, 2).CurrentRegion.Copy .Cells(3, 2)
Intersect(.UsedRange, .Rows(3)).ClearContents
.Cells(3, 2) = pvt.PivotItems(i).Name
.Columns.AutoFit
End With
zWb.SaveAs ztb.Path & "/" & .PivotItems(i).Name & ".xlsx", 51
zWb.Close False
Set zWb = Nothing
Next
End With
ztb.Worksheets("IJjejeje").Delete
Set zWs = Nothing
Set ztb = Nothing
Set pvt = Nothing
Application.DisplayAlerts = True
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Sub PvMake(ByVal ztb As Workbook)
Dim zWs As Worksheet
Dim i As Long
Dim pc As PivotCache
Dim v() As Variant
Set zWs = ztb.Worksheets("Sheet1")
v = Array("部署", "役職", "職種", "基本給")
ztb.Activate
If Not Evaluate("=ISREF(ztmpxxij!A1)") Then Sheets.Add.Name = "ztmpxxij"
With ztb.Worksheets("ztmpxxij")
If .PivotTables.Count > 0 Then
.PivotTables(1).TableRange2.Clear
End If
Set pc = ztb.PivotCaches.Create(xlDatabase, zWs.Cells(1).CurrentRegion)
With pc.CreatePivotTable(.Cells(3, 2), "P_明細")
For i = 0 To UBound(v)
With .PivotFields(v(i))
Select Case i
Case 0
.Orientation = xlPageField
.Position = 1
Case 1
.Orientation = xlColumnField
.Position = 1
Case 2
.Orientation = xlRowField
.Position = 1
Case 3
.Orientation = xlDataField
.Position = 1
End Select
End With
Next
With .PivotFields("合計 / 基本給")
.NumberFormat = "#,##0"
End With
End With
End With
Set pc = Nothing
Set zWs = Nothing
End Sub
Private Sub zDummyDtaMake(ByVal ztb As Workbook)
Dim zitem() As Variant
Dim b() As Variant
Dim y() As Variant
Dim s() As Variant
Dim v() As Variant
Dim m As Long
Dim i As Long
Rnd -5
m = 1000
ReDim v(1 To m, 1 To 7)
zitem = Array("ID", "部署", "役職", "氏名", "基本給", "職種", "考査")
b = Array("総務", "企画", "経理", "人事", "業務")
y = Array("部長", "課長", "係長", "主任", "社員")
s = Array("正社員", "嘱託", "派遣", "アルバイト", "臨時")
Do Until i >= m
i = i + 1
v(i, 1) = 10000 + i
v(i, 2) = b(Int((4 - 0 + 1) * Rnd + 0))
Select Case True
Case i Mod 1000 = 0
v(i, 3) = y(0)
Case i Mod 100 = 0
v(i, 3) = y(1)
Case i Mod 50 = 0
v(i, 3) = y(2)
Case i Mod 10 = 0
v(i, 3) = y(3)
Case Else
v(i, 3) = y(4)
End Select
v(i, 4) = "J - " & Split(Cells(i).Address, "$")(1)
Select Case True
Case v(i, 3) = y(0)
v(i, 5) = 800000
Case v(i, 3) = y(0)
v(i, 5) = 800000
Case v(i, 3) = y(1)
v(i, 5) = 500000
Case v(i, 3) = y(2)
v(i, 5) = 400000
Case v(i, 3) = y(3)
v(i, 5) = 250000
Case v(i, 3) = y(4)
v(i, 5) = 185000
End Select
Select Case True
Case v(i, 3) = y(4)
v(i, 6) = s(Int((4 - 0 + 1) * Rnd + 0))
Case Else
v(i, 6) = s(0)
End Select
v(i, 7) = Chr(65 + Int((5 - 0 + 1) * Rnd + 0))
DoEvents
Loop
With ztb.Worksheets("Sheet1")
.Cells(1).Resize(, 7) = zitem
.Cells(2, 1).Resize(UBound(v, 1), UBound(v, 2)) = v
End With
Erase zitem, v, b, y, s
End Sub
（隠居じーさん） 2020/08/19(水) 13:37
新規ブックより、雛形ブックを用意しておけばよいだけでした。
そうすると、こんな感じでもよいと思います。
Sub test()
Dim pvt1 As PivotTable
Dim pvt2 As PivotTable
Dim pvf As PivotField
Dim pvi As PivotItem
Dim wb As Workbook
Dim r As Range
Dim 部署名 As String
Set pvt1 = Worksheets("総括表").PivotTables(1)
Set pvt2 = Worksheets("明細表").PivotTables(1)
Set pvf = pvt2.PivotFields("部署")
コピペ先のブック（雛形）を開く
Set r = pvt1.TableRange1
総括表ピボットのデータ部分をコピペ
For Each pvi In pvf.PivotItems
部署名 = pvi.Name
pvf.ClearAllFilters
pvf.PivotFilters.Add xlCaptionEquals, , 部署名
Set r = pvt2.TableRange1
明細表ピボットのデータ部分をコピペ
保存名 = 場所 & "総括表(" & 部署名 & ").xlsx"
名前を付けて保存
コピペしたデータ部分をクリア
Next
End Sub
（マナ） 2020/08/19(水) 20:09
マナさん、ありがとうございます。
今実行してみたのですが、何も起こらないみたいなのですが、何か必要な準備がるのですかね
（ときま） 2020/08/20(木) 00:06
'************* pivotを書式を継承し、値に変換する **************
'分割して作業域にコピペすれば値になる
'作業域をpivot域に再度コピペし、作業域を削除
Private Sub paste_VF(pv As PivotTable)
Dim o As Long
Dim pr As Range
On Error Resume Next
Set pr = pv.PageRange
On Error GoTo 0
o = pv.Parent.UsedRange.Rows.Count + 1
If pr Is Nothing Then
With pv.TableRange1 'フィルター(Page)無し 1行目とそれ以外に分割コピペ
.Rows(1).Copy .Offset(o).Cells(1) '作業域に貼り付け
.Offset(1).Resize(.Rows.Count - 1).Copy .Offset(o + 1).Cells(1)
.Offset(o).Copy .Cells(1) '値と書式を貼り付け直し
.Offset(o).EntireRow.Delete '作業域削除
Application.Goto .Cells(1) 'ペースト範囲が選択されるので1セル選択にする
End With
Else
With pv.TableRange2 'フィルター有り ページ域とテーブル域に分割コピペ
pv.PageRange.Copy pv.PageRange.Offset(o).Cells(1)
pv.TableRange1.Copy pv.TableRange1.Offset(o).Cells(1)
.Offset(o).Copy .Cells(1)
.Offset(o).EntireRow.Delete
Application.Goto .Cells(1)
End With
End If
End Sub
（kazuo） 2020/08/20(木) 10:41
この部分は解決しましたか。
手作業でだめなものは、マクロでもできません。
なので、まずは手作業でできるか確認をお願いしました。
＞今実行してみたのですが、何も起こらないみたいなのですが、
＞何か必要な準備がるのですかね
準備どころか、マクロは完成していません。
日本語の文章の行は、
この位置に、こんなマクロが必要という意味です。
具体的にどう記述すればよいかわからなくてもよいです。
でも、全体の流れは理解してください。
これでは期待の結果にならないと思えば指摘してください。
（マナ） 2020/08/20(木) 19:36
先走ってしまいすいません。
（ときま） 2020/08/21(金) 22:03
では、シートコピーのかわりに、その方法にすれば
ボタンもマクロもコピーされないし都合がよいのではありませんか。
わたしの環境では、うまくいきませんが…
（マナ） 2020/08/21(金) 22:44
こちらでは、↑だと、ピボットのままになります。
１）雛形.xlsxを、マクロブックと同じフォルダに保存しておく ２）雛形.xlsxには、総括表シートと明細表シートがあること
Sub test()
Dim wb As Workbook
Dim pvt1 As PivotTable
Dim pvt2 As PivotTable
Dim pvf As PivotField
Dim pvi As PivotItem
Dim r As Range
Dim 部署名 As String
Set pvt1 = ThisWorkbook.Worksheets("総括表").PivotTables(1)
Set pvt2 = ThisWorkbook.Worksheets("明細表").PivotTables(1)
Set pvf = pvt2.PivotFields("部署")
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Path & "\雛形.xlsx")
Set r = pvt1.TableRange1
r.Resize(r.Rows.Count - 1).Offset(1).Copy wb.Worksheets("総括表").Range("B4")
For Each pvi In pvf.PivotItems
部署名 = pvi.Name
pvf.ClearAllFilters
pvf.PivotFilters.Add xlCaptionEquals, , 部署名
Set r = pvt2.TableRange1
With wb.Worksheets("明細表").Range("B4")
r.Resize(r.Rows.Count - 1).Offset(1).Copy .Cells
wb.SaveAs ThisWorkbook.Path & "\総括表(" & 部署名 & ").xlsx"
.Resize(r.Rows.Count, r.Columns.Count).ClearContents
End With
Next
wb.Close False
End Sub
（マナ） 2020/08/22(土) 21:17
（ときま） 2020/08/24(月) 12:31
（マナ） 2020/08/24(月) 19:53
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.