[[20041106233856]]　『ピボットテーブルの結果をコピー？？？』（エクセル姫）　ページの最後に飛ぶ

『ピボットテーブルの結果をコピー？？？』（エクセル姫）

たとえば、データと名付けられたシートのセルA1と同じ値を、既存のピボットテーブルで検索し、その結果を、データのシートに戻って埋め込む作業を、マクロでしてみようとするときに、とりあえず、コピーを使って、マクロを記録してみましたが、コピー範囲に問題があります。

この記録されたマクロの”Range（"A3:N19").Select　の　ところですが、”データ”と呼ばれるシート上のA1の値によっては、ピボットテーブルの検索結果は、A3から、N19以上のセル範囲が、必要となります。どのように、解決できるのか、ちょっとわかりません。どうしたらいいでしょうか？

    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("地域別").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("地域").CurrentPage= Worksheets("データ").Range("A1").Value

    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

いたらない説明で、ほんとにすみません。わかりにくかったでしょうか、、、。ほんとにすみません。私の質問は、マクロによって検索されるピボットテーブルの結果をそのピボットテーブルごと、違うシートにコピーしたいのですが、範囲の指定をどのように、していいのか、わからないんです。　もしどなたか、ご存知の方、おしえていただけませんか？　よろしくおねがいします。（エクセル姫）

 ピボットテーブルの回答はなかなか難しいというか、回答している方で使っている方が少なそうで、
 回答が出にくいですね(^_^A;

 本題の範囲の指定ですが、A3は固定ですよね。

 そうであれば、以下で範囲のコピーが出来ませんか。

 ※ただし、ピボットテーブルの右側にデータ無い、下にもデータが無い場合です。
    MyRow = Range("A65536").End(xlUp).Row
    MyRange = Range("IV" & MyRow).End(xlToLeft).Address
    Range("A3:" & MyRange).Copy

 もし、N列も固定であれば以下でも良いです。

    MyRow = Range("A65536").End(xlUp).Row
    Range("A3:N" & MyRow).Copy

 （川野鮎太郎）

 ピボットテーブルはよく知らないのですが・・・
 ピボットテーブル内を選択した状態で、
 ピボットテーブルツールバーの
 ピボットテーブル→選択→テーブル全体
 で選択してコピー貼り付けするのをマクロの自動記録したら
 参考になるコードが出てこないでしょうか?
 ちなみに↓のようなコードが出てきました。
 Sub Macro1()
    Range("C11").Select
    ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataAndLabel, True
    Selection.Copy
    Sheets("Sheet3").Select
    Range("B3").Select
    ActiveSheet.Paste
End Sub
　何かの足しにでもなれば・・・(Hatch)

 (・0・*)ホ,(゜0゜*)ホ--ッッ!!!
 ＿〆＼(．．;) メモメモ

 ※誤解のないように追加：
 ＞回答している方で使っている方が少なそうで、回答が出にくいですね(^_^A;

 決して、ピボットテーブルが使いにくいなどではないです。
 データの集計機能としては優れていると思います。
 使う機会に恵まれないって言った方が良いかな(^_^A;
 （川野鮎太郎）

エクセル姫より～　川野さん、Hatchさん、お時間いただいてどうもありがとうございます。今、Hatchさんのアドバイスを受けて、実験してみましたが、既存のピボットテーブルごと、移動してしまうとゆう結果になりました。（ピボットテーブル内のデータ量が多いので、マクロで常にピボットテーブルを作って、違うシートにはりつけとゆうことは、避けたいと思っているんですけど、その観点をかえれば、Hatchさんのアドバイスは、成功です！　ただ、そうなると、元のピボットテーブルのデータの量が３００００行以上あるので、マクロで毎回ピボットテーブルを作成すると、どこかに負担が、かかりそ～（あまりPCにくわしくないひとの見解で、すみません）そちらも試してみるべきでしょうか？　Hatchさん、どのようにおもわれますか？　よろしければ、ご感想きかせてください。　これから、川野さんの範囲指定、してみま～す！　

河野さ～ん、失敗中です。Y(>_<、)Y シクシク。　川野さんからいただいたマクロのコマンドをそのまんま、コピーして埋め込んだんです、以下のところを削除したあと。そうしましたら、ピボットテーブルの上方、一部だけが、貼り付けられるとゆう結果になってしまいました。多分、こちらの方に、非があるとおもいますが、（ほんとにマクロは初心者です）、川野さんに質問ですが、川野さんから、いただいたコマンドを埋め込む位置は、私が削除をした部分であってますか？　教えてください。

　　Range("A3:N19").Select

    Range("N19").Activate
    Selection.Copy

 私はやりたいことが理解できていません。
 1.ピボットテーブルを使って、あるデータの集計か何かをする。
 2.できたデータをどこかのシートにコピーする。
 3.元のピボットテーブルは不要なので削除する。
 ということになるのでしょうか?
 それとも、単なるデータの抽出でしょうか？
 それでしたらオートフィルタなどの機能でデータを抽出して
 抽出データをコピーする
  といったことが考えられます。
 毎回ピボットテーブルを作っていたらファイル容量が大きくなって
 ファイルが開けないなどのトラブルの原因になりそうです。
 データの集計など1回だけ使うのであれば、その都度削除するとか、
 作った1個のピボットテーブルの条件を変更して使い回すことも
 考えられます。

 # ピボットテーブルを使う機会が少ないので、的確な回答になっていないかも(^^;)
 　　(Hatch)

Hatchさん、ほんとに説明が不十分でご迷惑をおかけてしてます。すみません。　したいことを簡潔に、Hatchさんに習って箇条書きしてみます。

１．Sheet１のセルA１に値が入力される（このセルは、コンボボックスを利用しているため、セルA１で入力される値には制限があります。ピボットテーブルで検索可能な値のみの制限方法です。）

2.　Sheet２の既存のピボットテーブル（このピボットテーブルはすでにSheet１のセルA1の検索用にレイアウトされています）から、Sheet１のA1で選択された値に基づく検索結果（ピボットテーブル）をSheet１に、貼り付ける作業をすべて、マクロでしようと思ってます。

私が最終的にしたいことは、Sheet１をサマリーシートの様な活用方法で、ピボットテーブルから、検索される結果のほかに、その他もろもろの情報（シート１のセルAに選択される関連情報）を組み込みたく思ってます。だから、貼り付けられるピボットテーブルの行の量が検索される値が変わるごとに、常にかわること、Sheet１に貼り付けられるときに、Sheet1上の既存の情報に上書きされないようにすることなど、いろいろ難点がありまして、どのように克服するか、頭を痛めています。困り者です。ほんとに私に時間を下さってありがとうございます。感謝しています。

 σ(^◇^;)もピボットテーブルというのはあまり詳しくないっうかぁ、、
今日はじめてさわった(^^;; ヒヤアセ
うんでもって察するにデータの量が変わるってことかな？
つまり、、可変？？？
ピボットを選択してからピボットのメニューバーの中に
「データ」ってのがあるけど、、それでいいんじゃない？？
これが記録したものです。
xlDataOnly
ってなってるべv(=∩_∩=)v
どうかな？だめかな？？
（SoulMan）
Sub てすと()
    Range("A3").Select
    ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataOnly
    With Selection
        .Resize(.Rows.Count - 1, .Columns.Count - 1).Copy
    End With
    Sheets("Sheet3").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
End Sub
こんな風にするとデータの中身だけになったよv(=∩_∩=)v
2004/11/07　13:40

 # 川野さんやSoulManさんは質問の意図を理解されているよう・・・私はよく分かっていない(^_^;)
多分、SoulManさんの方法で良さそう・・・でもエラーがでた・・・
　　　(アプリケーション定義またはオブジェクト定義のエラーです。(?_?)　)
ということで、SoulManさんへタッチ　　( ^-^)/＼(^o^ )
　　　(Hatch)

みなさん、ほんとにどうもありがとうございます。Hatchさんも、一緒に考えていただいて、ほんとにうれしく思います。SoulManさん、これは、すべて記録だけで、できますか？実験してみたいんだけど、どのような手順をふめばいいのかわかりません。ほんとに初心者のくせに、したいことだけは、いっちょまえとゆうのか、、、。　ぜひ、私がしたいことを成功させて、みなさんにも、活用する機会があればと願うばかりです。ご迷惑ばかりで、ごめんなさい。

 あまりいいコードとは言えないけど、、とりあえずってことで(^^;; ヒヤアセ
アップしました。
v(=∩_∩=)v
（SoulMan）
Sub てすと()
    With Worksheets("sheet4")
        .Select
        .Range("A3").Select
        .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataOnly
    End With
    With Selection
        .Resize(.Rows.Count - 1, .Columns.Count - 1).Copy
    End With
    Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
End Sub
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0133.xls
手順は
ピボットのシートを選択
ピボットを選択
ピボットのメニュー→選択→テーブル全体
もう一度
ピボットのメニュー→選択→データ
リサイズは後からちょっこと書きました。
コピー
シート3を選択
形式を選択して貼り付け→値
Esc
↓これも後からちょっことかきました。
Range("A65536").End(xlUp).Offset(1).
どうでしょう？

SoulManさん、どうもありがと。私の説明が不十分だったことをほんとに反省していますが、もう少しだけお時間をください。SoulManさんが作成されたSheet１のデータテーブルをもとに、たとえば、担当者で検索され、データが抽出されるピボットテーブルをSheet４に準備しておきます。サマリーシート的活用されるSheet３を準備して、あるセルにその担当者のリストをコンポボックスをもちいてそのセルの値を確定できるようにも、しておきます。すると、Sheet３のコンボボックスで選択されるたびに、マクロによって、Sheet４のピボットテーブルが、その担当者のデータを抽出し、そのSheet４上のピボットテーブルごとSheet３に、コピーして貼り付けられるとゆうことをしたいんです。ただSheet３では、ピボットテーブルだけではなくて、そのほかもろもろと、その担当者に関するデートを埋め込みたいために、確定されるピボットテーブルの範囲の指定、貼り付けされる際の範囲の指定を、固定できない事が難点なんです。もし、データが担当者名で整理された多種多様なデータが複数のシートにはいるとき、、担当者名から、データをよみだして、サマリーシートに集めたいと思ってるんです。ほんとに、くどくてごめんなさい。

 うん？抽出されるデータの量によって可変にならない？？
それが問題だったんじゃないの？
今、どこが問題なの？
v(=∩_∩=)v
（SoulMan）

SoulManさん、ほんとに言葉たらずで、ごめんなさい。SoulManさんが作ってくれたシートなんですが、データのみが抽出されませんか？ピボットテーブルは、一応見やすいので、その抽出される部分だけを丸ごと、サマリーのシートに貼り付けたいんです。

このシートを利用する人がたとえば、今回は、SoulManさんにまつわるデータがみたいというときに、Sheet３のコンボボックスにSoulManさんの名前をドロップダウンリストから選択して、設置されたマクロボタンをおすと、そのシート上に、ピボットテーブルが現れるとゆうことをしたいんです！そのシート上には、その他もろもろと、情報が、くみこまれていますので、別シートのピボットテーブルをSheet3にコピーしたのち貼り付けるとゆうことに、失敗中です。単に貼り付けるだけではなく、他のデータを上書きしてけさないようにとゆうことにも、いくたびも、失敗してます。。。Y(>_<、)Y

ほんとに、忍耐強く、つきあっていただいて、どうもありがとうございます。

 あっ、リサイズが余分だったのね(^^;;;
これで、データが全部コピーされるわ
これ以上になるとHatchさんと同じになっちゃうから多分これでいいと思うけど
後は貼り付ける場所ね？どこ？？
今は、シート3のA列の最下部に追加するようになってるけど。。
どうかな？？
遠慮しなくていいざんすよ！わかる範囲で答えてますからv(=∩_∩=)v
（SoulMan）
Sub てすと()
    With Worksheets("sheet4")
        .Select
        .Range("A3").Select
        .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataOnly
    End With
    Selection.Copy
    Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
End Sub

 >その抽出される部分だけを丸ごと、サマリーのシートに貼り付けたいんです。
こっちの方が近いかな？？
（Soulまん）
Sub てすと()
    With Worksheets("sheet4")
        .Select
        .Range("A3").Select
        .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataOnly
    End With
    With Selection
        .Offset(-1, -1).Resize(.Rows.Count + 1, .Columns.Count + 1).Copy
    End With
    Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
End Sub

 あらぁ、、今、名前を見て思ったけど、お姫様だったのね(^^;;;
ころっと態度が変わるSoulまんちゃんv(=∩_∩=)v
このパターンの中にどれか気に入ったのがあるでしょう？？
ないかな？？（￣□￣；）！！
（SoulMan）
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0134.xls
Sub てすと()
Dim MyRow As Long
Dim MyCol As Long
    With Worksheets("sheet4")
        .Select
        .Range("A3").Select
        .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotSelect "", xlDataOnly
    End With
    With Selection
        MyRow = .Rows.Count + 2
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Application.CutCopyMode = False
End Sub
罫線もあった方がいいのかな？？
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0136.xls

 わかった(-_☆)きらり
こうじゃない？？もしかしてぇ？？？
うん？？違うかな？？
（SoulMan）
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRow As Long
Dim MyCol As Long
If Target.Address <> "$H$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
    With Worksheets("sheet4")
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1")
            .PivotFields("品名").CurrentPage = Target.Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 2
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Me.Select
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
アップしたままだと少し変なので、保存してからお試しください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0139.xls
ちょっと、わかるとピボットって面白いねv(=∩_∩=)v
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh1 As Worksheet
Dim MyRow As Long, MyCol As Long
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Wsh1 = Worksheets("テーブル")
Me.Range("A3").CurrentRegion.Clear
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotFields("品名").CurrentPage = Target.Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 2
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Me.Range("A3")
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Me.Select
    Target.Select
    Me.Range("A3").CurrentRegion.Columns.AutoFit
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Set Wsh1 = Nothing
End Sub
アップしたままだと少し変なので、保存してからお試しください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0141.xls

SoulManさん、ほんとにどうもありがと。Up139のワークブックがかなり私が作ろうと思っているものに近いです！（＾＾）　あともう一声、って思わずいってしまいそうになったくらい近いし、そこまでのプロセスはほんとに同じです！つたない説明からサンプルまで、作っていただいてほんとに、ありがと。あと、一声の部分は、（まだ迷惑をおかけしょうとしてます！すみません）　Sheet3のドロップダウンリストから値が選択し、あの緑色のマクロボタンを押すと、そのSheet上に、ドロップダウンリストがあらわれるようにしたいんです。もうすこし、一緒に考えていただけないでしょうか？

Up141のワークブックの抽出とゆうシートなんですが、たとえば、セルA12に、別のデータが、はいっているとしたら、”すべて”を選んだとたんに、そのセルは、ピボットテーブルのために使われてしまい、既存のデータは、削除されてしまうということが、おきてしまいました。Y(>_<、)Y 　この場合の対策さえできれば、Up141は、いい方法だと、思います！よろしくおねがいします。　ほんとに、少しでも、楽しんでいただければ、幸いですがご迷惑ばかりでしたら、ほんとに、ごめんなさい。

 >セルA12に、別のデータが、はいっているとしたら
で、どうしたいの？
v(=∩_∩=)v
（SoulMan）

SoulManさん、とっても、早いレスどうもありがと、ほんとに助かります！もしも、１２行目にデータがはいってるなら、その行が下にずれ落ちるとゆう方法にしたいです！単なる貼り付けじゃなくて、インサート式で、もっていきたいんです。

 抽出先もクリアーにしなくちゃいけないし、12行目は残したいのかな？
抽出されたデータの数が9よりも多かったら、インサートそうでなければ何もしない。
ただし、A3から11行目までとデータの幅はいつもクリアーにします。
これで、いいかな？v(=∩_∩=)v
（SoulMan）
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh1 As Worksheet
Dim MyRow As Long, MyCol As Long
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Wsh1 = Worksheets("テーブル")
    With Me.Range("A3")
      .Resize(9, .CurrentRegion.Columns.Count).Clear
    End With
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotFields("品名").CurrentPage = Target.Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 2
            If MyRow > 9 Then
                Me.Rows("12:12").Insert Shift:=xlDown
            End If
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Me.Range("A3")
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Me.Select
    Target.Select
    Me.Range("A3").CurrentRegion.Columns.AutoFit
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Set Wsh1 = Nothing
End Sub
すみません。思いっきり間違えたぁ＿／￣∥○
ごめんちゃいm(__)m
2004/11/07　22:22

要求度がかなりわがままでごめんなさい、、。　実はこのシートを利用する人は、かなり年をいっておられる方で、年代的にPCに弱い方々になんです。けれども、一度そのシートができあがれば、簡単に必要な情報がマクロボタンの一押しと、プリントボタンを押すだけで、ハードコピーが手に入るとゆう、ちょっとした強い見方になってもらえるようなシートになるだろうって信じていて、そんなシートを作りたいんです。　もうすこしだけ、力を貸してください。と、ここまで、書いていたら、SoulManさんのレスが、入った模様、、、。チェックしてみようとおもいます！どうもありがとうございます

SoulManさん、サンプルをリンクさせていただいてもいいですか？ほんとにVBAは、初心者で、コマンドから理論的に理解するのは、１行ぐらいとゆう不束者です。よろしくおねがいします。

 お姫様には、弱い(^_^; あははは…
アップしたままだと少し変なので、保存してからお試しください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0142.xls
v(=∩_∩=)v
（SoulMan）

SoulManさん、ダウンロードしてみましたが、マクロが使えないようです。
(_ _。)・・・しゅん。

 (「･･)どれどれ..うん？今、DLしたけど、普通にうごくべ
ツール→マクロ→セキュリティをチェックしてみて
それか、
Application.EnableEvents = True
は可能性が低いしなぁ、、、
あっ、有効にして開いてる？？
最初のコードを間違ったからね。PCを再起動してみる？？
まぁ、落ち着いてやったら動くよ。。。多分
だいじょうびv(=∩_∩=)v
（SoulMan）

あっできましたっ！　ごめんなさい。SoulManさん、もしもこの抽出のシート上で、何度か、検索がおこなわれたら、既存のデータは、確かに削除されることなく残されますが、GrandTotalの行の出現がでますか？　それは、クリアーできますか？

 >GrandTotal
ってなんだべ？？
v(=∩_∩=)v
（SoulMan）

多分、元のピボットテーブルからきてると思われますが、何度かグリーンのセルから、値を検索するうちに、既存デートとの間に、Grand　Total　ってゆう行が、ふえていきませんか？

 σ(^◇^;)のはExcel2000だけど、ないように思うけど？？？？
よくわかんない｡･ﾟﾟ･(>_<)･ﾟﾟ･｡
なんせ今日はじめてやったもんなんで（￣□￣；）！！
（SoulMan）

私もExcel2000ですが、何かおかしいのかな。。。もも、りんご、みかん、という具合で、検索をつづけていたら、元のデータ（A１２行以下）のレイアウトが、こわされていってしまいました。　SoulManさん、今日はほんとに長いお時間おつきあいくださいまして、どうもありがと。私は、そろそろ、明日の準備をしようと思いますので、今日はこの辺できりあげさせていただきますが、ぜひぜひ、今後もこの一件に、ご協力くださいませんか？成功した暁には、などとゆうお礼さえもできないんですけど、、、。多々、このサイトがあったことと、SoulManさんのような、手厚い手助けをいただけることに、感謝しています。
おやすみなさい。♪<(゜ー^)ノ^*・'゜☆。.:*:・'☆'・:*:.。.:*:・'゜:*:・'゜☆

     With Me.Range("A3")
      .Resize(9, .CurrentRegion.Columns.Count).Clear
 　　　　　　 ↑この9が範囲が変わったときに対応してないので、クリアされている範囲が足りないみたい。

     With Me.Range("A3")
      .Resize(.End(xlDown).Row - 2, .CurrentRegion.Columns.Count).Clear

 これでいけるかな。
 （川野鮎太郎）

 上記はよく読んだら勘違いでした＿/￣|○ il||li
 ※要するにManちゃんのサンプルで言うテーブルシートの10行目以下に別のデータがある場合に、
 上書きされないようにってことだと判断しました。

 少しベタな方法になってしまいましたが、こうかな？(^_^A;
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Dim MyRow As Long, MyDataRow As Long, MyCol As Long
Dim MyRow1 As Long, MyRow2 As Long
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Wsh2 = Worksheets("データ")
    With Wsh2
        MyDataRow = .Range("A1").CurrentRegion.Rows.Count
    End With
Set Wsh1 = Worksheets("テーブル")
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotSelect "", xlDataOnly
        End With
        MyRow1 = Selection.Rows.Count
            .Rows(MyRow1 + 5 & ":" & MyRow1 + 5 + MyDataRow).Insert Shift:=xlDown
    End With
    With Me.Range("A3")
      .Resize(.End(xlDown).Row - 2, .CurrentRegion.Columns.Count).Clear
    End With
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotFields("品名").CurrentPage = Target.Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 2
'            If MyRow > 9 Then
'                Me.Rows("12:12").Insert Shift:=xlDown
'            End If
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Me.Range("A3")
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Me.Select
    Target.Select
    Me.Range("A3").CurrentRegion.Columns.AutoFit
    With Wsh1
        MyRow2 = .Range("A3").CurrentRegion.Rows.Count
        .Rows(MyRow2 + 3 & ":" & MyRow2 + 3 + MyDataRow - (MyRow2 - MyRow1) + 2).Delete Shift:=xlUp
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Set Wsh1 = Nothing
Set Wsh2 = Nothing
End Sub

 ※抽出先シートの下方にもデータがある場合は、もう少し追加が必要かな・・・。

 （川野鮎太郎）

 おはぁよ
なぁ～～んだ、、そうゆうことかぁ、、じゃこれでいいんじゃないの？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh1 As Worksheet
Dim MyRow As Long, MyCol As Long
If Target.Address <> "$A$1" Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Wsh1 = Worksheets("テーブル")
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotFields("品名").CurrentPage = Target.Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 2
            If Not IsEmpty(Me.Range("A3").Value) Then
                Me.Rows("3:" & MyRow + 3).Insert Shift:=xlDown
            End If
        MyCol = .Columns.Count + 1
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Me.Range("A3")
        .PasteSpecial Paste:=xlValues
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Me.Select
    Target.Select
    Me.Range("A3").CurrentRegion.EntireColumn.AutoFit
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Set Wsh1 = Nothing
End Sub
アップしたままだと少し変なので、保存してからお試しください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0144.xls
ところで、そのデータを選択するところがあるじゃん？
σ(^◇^;)は入力規則を使ってるけど、それを抽出先のシートに表示させることって
できるのかぁ？？どうもトピ主さんのはそんな風になってる様な気がするんだけど、、
ピボットは使ったことがないから、機能そのものがよくわからない｡･ﾟﾟ･(>_<)･ﾟﾟ･｡
v(=∩_∩=)v
（SoulMan）

 意味が伝わってないな(ﾉ_･｡)
 テーブルシートのA10に川野鮎太郎って入れてから、全てで抽出してみて＿/￣|○ il||li
 （川野鮎太郎）

 うぅ～～ん、今一よくわからないんだけど、、
なんでテーブルの下に川野鮎太郎って入れるわけ？？？
テーブルシートはテーブルシートで独立させてたらいいんじゃないの？？？
うぅ～～～ん、、まだ、よくわかってないな(;＞_＜;)びぇぇぇぇん
v(=∩_∩=)v
（SoulMan）

 それはそうだけど・・・。
 質問者のお姫様がおっしゃってますので・・・(^_^A;
 というより、ピボットで集計したデータの下にデータを加えて、全体のシートを作るってこともあるんじゃないかな。
 （川野鮎太郎）

 なぁ～～るほどぉ、そうゆことかぁ、、
でもそれは、別シートにコピーすることとは関係ないんじゃないの？？
もともと、そうゆことなんじゃないの？？
あっ！コピーするから、
 >GrandTotal
ってのが出るのかなぁ？？？そんなもんないけどなぁ？？？
鮎ちゃんのは、そんなの・・ある？？
 >GrandTotal
ってやつ？？？
ようわからん、、ちょっとむずいね(^_^; あはははは…
v(=∩_∩=)v
（SoulMan）

 GrandTotal=総計
 前の0142のファイルの場合に、総計が何行も追加されていってたでしょ。
 多分そのことだと思う。
 んで、本来は抽出シートには、選んだ項目の一覧だけ出れば良いんじゃないのかな？

 ということは、抽出シートは何で必要なの？？？って疑問に思ったことで気づいたんだけど、
 もしかしたら・・・、本当はテーブルシートだけで良いのだけど、
 テーブルシートのA10以下にデータが入っていて、項目を選択した時点で、セルを削除しますか？って聞いてくるので、
 いいえを選択では、抽出できないし、はいにすると下のデータが削除されるからってことかな・・・。
 （あくまで想像で書いてます(^_^A;）
 （川野鮎太郎）

 こんにちは。
 忙しくて口出しはできませんが、up139が近いといっているんだから
 どんどん追加（挿入）されていくものがいいのでしょう。

 >Sheet3のドロップダウンリストから値が選択し、
 >あの緑色のマクロボタンを押すと、そのSheet上に、
 >ドロップダウンリストがあらわれるようにしたいんです。

 ただ、間違って選択したときに直すのが大変なので、
 『あの緑色のマクロボタン』（吹き出しのこと？）を押したタイミングで挿入と
 したいのでは？

 ドロップで選択
       ↓
 緑ボタンで追加
       ↓
 ドロップで選択
       ↓
 緑ボタンで追加

 ことばのニュアンス的には、その都度新しいドロップダウンリストを
 出したいみたいだけど...

 そして総計の部分はいらないんでしょ、多分。

 （ramrun）と、私は解釈しました。

 わかった。v(=∩_∩=)v
チェンジイベントじゃなくて好きな時に実行
GrandTotal=総計　は不要
でもって、下にどんどん追加していく
じゃないの？？？
はじめから、そう言ってくれりゃいいのにぃ、、って、そう言ってるじゃんってかぁ（￣□￣；）！！
これで、怪傑！解決丸ざんしょ？？お姫様？
v(=∩_∩=)v
（SoulMan）
Option Explicit
Sub てすと()
Dim Wsh1 As Worksheet, Wsh2 As Worksheet
Dim MyRow As Long, MyCol As Long
Application.ScreenUpdating = False
Set Wsh1 = Worksheets("テーブル")
Set Wsh2 = Worksheets("抽出先")
    With Wsh1
        .Select
        .Range("A3").Select
        With .PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ3")
            .PivotFields("品名").CurrentPage = Wsh2.Range("A1").Value
            .PivotSelect "", xlDataOnly
        End With
    End With
    With Selection
        MyRow = .Rows.Count + 1
        MyCol = .Columns.Count
        .Offset(-2, -1).Resize(MyRow, MyCol).Copy
    End With
    With Wsh2.Range("A65536").End(xlUp).Offset(2)
        .PasteSpecial xlPasteValues
        .CurrentRegion.EntireColumn.AutoFit
        With .Resize(MyRow, MyCol)
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
    End With
    Wsh2.Select
    Wsh2.Range("A1").Select
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Set Wsh1 = Nothing
Set Wsh2 = Nothing
End Sub
アップしたままだと少し変なので、保存してからお試しください。
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0145.xls

 元の質問のままで考えたらこうなんだろうか・・・。
私は追加ではなく変更で考えました。
http://skyblue123.hp.infoseek.co.jp/Excel/Hime.xls
ダウンロードして試してください。
 （川野鮎太郎）

w(☆o◎)wおぉぉぉぉぉぉぉっぉ

 さすがぁ、、姫のはぁーと・‥…・・・★！！
をげっちゅうしましたね(-_☆)キラリンコ・・正解でしょう？
いや、どれか正解があるでしょう？？
v(=∩_∩=)v
（SoulMan）

( ^-^)ノ(* ^-^)ノこんばんわぁ♪　川野さんにまで、サンプルを作っていただきましたっ！ほんとにどうもありがとうございます。今、私が作成しようとしているワークブックに、最も近い物は、実際、SoulManさんがつくってくれたサンプルのような　3つのシートの構成です。（サマリーシート、データ、ピボットテーブル、このワークブックを使ってくれるおばちゃんやおじちゃんは、まずサマリーシートにいって、ドロップダウンリストから、検索したい値を選択します。そして、マクロボタンを押すと、そのシートにデータが集まる！だから、データと、ピボットテーブルシートは、実際、誰もみる必要はないんです。）川野さんのサンプルシートは、ピボットの元のデータシートに、ドロップダウンリストをはめ込まれてますが、マクロの作り方次第で、私の既存のシートを変更することなく、”使えそう～これもいい～！って、思いました。(*^。^*)

川野さん、もうひとつだけ、大変ご迷惑なおねがいがあるんですけど、きいていただけますか？　川野さんに、書いていただいたVBAのコマンド1行1行に、何をしているのかその行の下でもいいし、横でもいいので、簡単な説明おねがいできますか？そこから、応用範囲を、自分なりに広げて、既存のワークシートの構成をいかしたいなって。Dim Wsh1 As Worksheet, Wsh2 As Worksheet　このコマンドにもつまづいてしまいました。(_ _。)・・・しゅん。何をしてくれてるんだろ～？こんな、私でほんとに、ご迷惑ばかり、ごめんなさい。　よろしくおねがいします。

PS　SoulManさん、まだ、もすこしだけ、私のシートを完成するまでには時間がかかりそうです。ぜひぜひ、今後もご指導ください。川野さんには、とっても、感謝してますし、同じように、SoulManさんに、感謝します。　ここまで辿りつけたのも、SoulManさんのいくつかのサンプルシートのおかげだとも思ってます。ほんとに、どうもありがとうございます。
　

( ^-^)ノ(* ^-^)ノこんばんわぁ♪　川野さん、無理なお願いをして、ほんとにすみませんでした。少しずつですが、自分なりに学習していこうとおもいます。ただ、これまで、ご指導いただいた、川野さんや、Hatchさん、SoulManさん、このサイトの管理者のKazuさん、みなさんに、ほんとに感謝していて、心から、お礼がいいたいです。ほんとにどうもありがとうございました。

 こんばんは。
 一応私の分のコードの説明を付け加えておきました。
 ご覧になる場合は、再度ダウンロードして確認してください。
 あんまり詳しく見ちゃ(*/∇＼*)キャ
 （川野鮎太郎）

川野さん、ほんとにどうもありがとうございます。=*^-^*=にこっ♪　かなり、わがままなおねがいをしてしまったと、反省したいたところでしたので、うれしさ倍増です　知識だけじゃなくて、やる気もみなさんから、いただいてます。どうもありがとうございます。ｐ(*^-^*)ｑがんばります♪

コメント返信：

[ 一覧(最新更新順) ]

[[20041106233856]] 『ピボットテーブルの結果をコピー？？？』（エクセル姫） ページの最後に飛ぶ

w(☆o◎)wおぉぉぉぉぉぉぉっぉ

[[20041106233856]]　『ピボットテーブルの結果をコピー？？？』（エクセル姫）　ページの最後に飛ぶ