こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

マクロ登録したピボットが重いのです

以前、http://oshiete1.goo.ne.jp/qa3362330.html を質問させていただいた者です。

同じくエクセル2003で、ピボットを作りました。VBAで、
Selection.End(xlDown).Select
N = Selection.Row
を登録し、下記のプログラムを作ったところ、★の部分で再計算が始まり、終了まで非常に時間がかかってしまいます(1分程)。マクロは作動しますので、時間がかからないようにする方法はあるでしょうか。よろしくお願いします。


Sheets("data").Select
Range("D1").Select
ActiveCell.FormulaR1C1 = "担当"

Selection.End(xlDown).Select
N = Selection.Row

ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],number!C[-3]:C[-2],2,0)"
Selection.AutoFill Destination:=Range("D2:D" & N)
Range("D2:D" & N).Select
Selection.Copy
★ Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("answer").Select
Range("A1").Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"data!R1C1:R" & N & "C4").CreatePivotTable TableDestination:="[集計(1).xls]answer!R1C1", _
TableName:="ピボットテーブル1", DefaultVersion:=xlPivotTableVersion10
With ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("性別")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("商品番号")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("ピボットテーブル1").AddDataField ActiveSheet.PivotTables( _
"ピボットテーブル1").PivotFields("価格"), "合計 / 価格", xlSum
Columns("A:A").ColumnWidth = 30
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
End Sub

投稿日時 - 2007-09-27 21:01:37

QNo.3382236

すぐに回答ほしいです

質問者が選んだベストアンサー

こんにちは。

ピボットは重くないですよ~。(^_^)

> 時間がかからないようにする方法…
関数式を使わずに For Each ステートメントでしらみつぶしに調べては如何でしょうか?

Sheets("data").Select
から
Application.CutCopyMode = False
に該当するコードです。
関数式を元に組んで見ましたが意図した結果にならなかったらすみません。Offsetプロパティあたりを修正すればできると思います。<(_ _)>

Dim DataSht As Worksheet, NumSht As Worksheet
Dim varData() As Variant
Dim myCount As Long, i As Long
Dim Target As Range, Target2 As Range

With ThisWorkbook
  Set DataSht = .Worksheets("data")
  Set NumSht = .Worksheets("number")
End With

With DataSht
  .Range("D1").Value = "担当"
  myCount = .Range("A2").End(xlDown).Row
  ReDim varData(1 To myCount, 0)
  i = 1
  For Each Target In .Range("D2:D" & myCount)
    For Each Target2 In NumSht.Range("A:A").SpecialCells(xlCellTypeConstants, 3)
      If Target.Offset(, -3).Value = Target2.Value Then
        varData(i, 0) = Target2.Offset(, 1).Value
        i = i + 1
        Exit For
      End If
    Next Target2
  Next Target
  With .Range("D2:D" & myCount)
    .ClearContents
    .Value = varData
  End With
End With
Erase varData
Set NumSht = Nothing
Set DataSht = Nothing

投稿日時 - 2007-09-29 01:48:26

お礼

お礼が遅くなって申し訳ありません。参考にさせていただいたら動きました。ありがとうございました。

投稿日時 - 2007-09-30 22:03:56

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

-広告-
-広告-

回答(1)

-広告-
-広告-

あなたにオススメの質問

-広告-
-広告-