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

質問

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

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

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

回答No.1

OtenkiAme · ベストアンサー

こんにちは。

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

> 時間がかからないようにする方法…
関数式を使わずに 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

お礼

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