Results of 1 - 1 of about 2422 for ピボットテーブル (0.004 sec.)
- [[20200816225122]]
- #score: 4769
- @digest: 6956ccd2ec2820c0d170f464c5563a79
- @id: 84795
- @mdate: 2020-08-24T10:53:06Z
- @size: 17731
- @type: text/plain
- #keywords: 総括 (39854), ztmpxxij (36340), 括表 (31963), tablerange1 (28627), pivotitems (16958), 業域 (13650), 細表 (13226), ztb (13022), pivottables (12292), 部署 (11569), 明細 (9677), pivottable (9142), ピボ (7687), pivotfields (7656), タ部 (6859), 署名 (5202), 雛形 (5177), 規ブ (4930), 表") (4606), ル表 (3843), トテ (3665), ボッ (3571), マナ (3094), 隠居 (2798), 新規 (2355), ット (2346), ーブ (2311), 2020 (2270), テー (2248), case (2189), ピペ (2047), ブッ (1973)
- 『複数シートのコピーからブック保存まで』（ときま）
下記のようなことがしたく、マクロの記録でやってみましたが、コードが多いので、シンプルに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 ---- ご回答ありがとうございます。 いろいろ参考に下記コードまでたどり着きました。下記3点お力添えいただけないでしょうか。 ?@新しいブックにコピーを作る際、sheet3.4のVBAまでコピーされるのか、マクロなしのファイル形式では保存できませんというメッセージがでるのですが対策がありますか? ?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 ---- こんにちは ^^ ↑ で 動作しているなら。。。^^; 1.保存時、ファイルフォーマット［51］を指定してみてください 2.XlPasteTypeを xlPasteAll -4104 に変えるといいですよ。 3.コピペ処理が、ループからもれているのでは select句要るのかなぁ?やっていないので解りませんが。^^; コード全体の件は、相済みませんが、当方でテスト出来る環境に御座いませんので 現状では何とも。。。各シートのセル番地が解る情報を教えて頂けると［違いが判る ダミー情報で］お手伝い出来るかもしれません。ちょっと見では。。一気に新規ブック 作成すると、片方しかアクティブにはならないので、もう少し丁寧なロジックが必要 かもしれませんね。保存先パス取得も問題あるかも?。。。ピボットにお詳しい方の 回答をお待ちくださいませ。m(_ _)m （隠居じーさん） 2020/08/18(火) 17:12 ---- 追伸 ＞＞保存先パス取得も問題あるかも?。。。 有りませんでした。。。済みません。m(_ _)m ピボット、作ってみます。←勉強しなおそう。(￣▽￣) m(_ _)m （隠居じーさん） 2020/08/18(火) 17:36 ---- コピーする2つのシートの名前とレイアウトを説明してください。 何をしたいか不明瞭な部分が多いです。 （マナ） 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 ---- 1）ピボットの元データは、別のシートにあるのでしょうか 2）「総括表」シートは、5部署に共通なのでしょうか 3）提示されたコードで値貼り付けしていますが、 それで目的の結果になると考えてよいですか （マナ） 2020/08/18(火) 22:47 ---- 1）はい、同ブック内の別シートにあります。 2）はい、「明細」シートのみA部署に配布するときは、A部署の情報のみ見れる状態にして配布したいです。 3）恥ずかしながらここのコードが一番理解できておりません。 家のパソコン（office2013）で実行した時は、値と書式でちゃんとコピーができるのですが、会社のパソコン（office2016）で実行すると、1行目のタイトルのみ値と書式のコピーがされ、ピボットテーブル表の部分は値コピーのみで作成されてしまします。 （ときま） 2020/08/18(火) 23:34 ---- ポイントだけですが、こんな流れではだめでしょうか。 まずは手作業で確認してみてください。 1）新規ブック作成（シート数2） 2）総括表ピボットを新規ブックにコピー（※） 3）明細ピボットで、部署Aでフィルター 4）明細ピボットを新規ブックにコピー（※） 5）新規ブックを名前を付けて保存 6）3）〜5）すねての部署で繰り返し （※）ピボットをコピーするとき、 ヘッダー部分とデータ部分の2回に分けてコピペ （マナ） 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 ---- ＞1）新規ブック作成（シート数2） 新規ブックより、雛形ブックを用意しておけばよいだけでした。 そうすると、こんな感じでもよいと思います。 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 ---- ＞会社のパソコン（office2016）で実行すると、 ＞1行目のタイトルのみ値と書式のコピーがされ、 ＞ピボットテーブル表の部分は値コピーのみで作成されてしまします。 この部分は解決しましたか。 手作業でだめなものは、マクロでもできません。 なので、まずは手作業でできるか確認をお願いしました。 ＞今実行してみたのですが、何も起こらないみたいなのですが、 ＞何か必要な準備がるのですかね 準備どころか、マクロは完成していません。 日本語の文章の行は、 この位置に、こんなマクロが必要という意味です。 具体的にどう記述すればよいかわからなくてもよいです。 でも、全体の流れは理解してください。 これでは期待の結果にならないと思えば指摘してください。 （マナ） 2020/08/20(木) 19:36 ---- 返事が遅くなりました、すいません。 手作業では、シート全選択して、最初に値貼り付け、次に書式貼り付けをして期待通りの結果となりました。 マナさんの考えてくれた工程でも上手く行きました! 先走ってしまいすいません。 （ときま） 2020/08/21(金) 22:03 ---- ＞手作業では、シート全選択して、最初に値貼り付け、次に書式貼り付けをして期待通りの結果となりました。 では、シートコピーのかわりに、その方法にすれば ボタンもマクロもコピーされないし都合がよいのではありませんか。 わたしの環境では、うまくいきませんが… （マナ） 2020/08/21(金) 22:44 ---- そうですね。 上記方法でやろうしているのですが、私のレベルではまだ上手くコードが書けないので一から勉強してみます。 （ときま） 2020/08/22(土) 01:05 ---- ＞シート全選択して、最初に値貼り付け、次に書式貼り付け こちらでは、↑だと、ピボットのままになります。 1）雛形.xlsxを、マクロブックと同じフォルダに保存しておく 2）雛形.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 ---- マナさん、返事遅くなり申し訳ございません。 最後まで付き合っていただきありがとうございます。 r.Resize(r.Rows.Count - 1).Offset(1).Copy .Cells ここの部分でデバックしてしまいます。 どうしてでしょうか? （ときま） 2020/08/24(月) 12:31 ---- その行では、どんな操作が行われているか理解できていますか。 わかるなら、手作業で、実行してみてエラーがでるか確認してください。 （マナ） 2020/08/24(月) 19:53... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202008/20200816225122.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97057 documents and 608292 words.
訪問者：