マクロ実行でエラーになるが、リセットすると動作可
office2010
下記のマクロを実行すると、macro_a5の
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"work!R1C3:R1048576C3", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="", TableName:="ActiveSheet.Name", DefaultVersion _
:=xlPivotTableVersion14
が黄色く表示されれ、
実行時エラー'1004'
アプリケーション定義またはオブジェクト定義のエラーです
とのポップアップエラーが発生します。
ポップアップのデバッグでmacro_a5の部分から、
マクロのリセット→中断→リセット→実行すると継続動作可能で最後まで終了します。
何故でしょう？
マクロは、学習機能使いながら、ブロック単位(macro_a*)で各々の動作を確認しながらのものとなっています。また、マクロの中身の詳細も省略させていただきます。
文字数制約で全文掲載出来ないので、クリア処理等は省略しています。
悪い部分を修正していただけたらと思います。
Sub macro_a1()
'sheet5シートB1に表示される シリアルで抽出
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("work").Select
Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
'…途中省略
macro_a2
End Sub
Sub macro_a2()
Columns("J:S").Select
Selection.Delete Shift:=xlToLeft
Columns("D:H").Select
Selection.Delete Shift:=xlToLeft
Columns("C:E").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Columns("C:C").Select
Selection.Copy
Sheets("Sheet4").Select
Range("B1").Select
ActiveSheet.Paste
Range("A1") = "code"
Range("A2:A" & (Range("B" & (Rows.Count)).End(xlUp).Row)).Value = "=Sheet3!RC&Sheet3!RC[1]"
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
macro_a3
End Sub
Sub macro_a3()
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Sheet4!R1C1:R" & Worksheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Row & "C2", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="", TableName:="ActiveSheet.Name", DefaultVersion _
:=xlPivotTableVersion14
Cells(1, 1).Select
With ActiveSheet.PivotTables("ActiveSheet.Name").PivotFields("code")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("ActiveSheet.Name").AddDataField ActiveSheet.PivotTables( _
"ActiveSheet.Name").PivotFields("N_KOUSU"), "合計 / N_KOUSU", xlSum
Columns("A:B").Select
Selection.Copy
Sheets("work").Select
Range("A1").Select
ActiveSheet.Paste
macro_a4
End Sub
Sub macro_a4()
Columns("C:C").Select
Selection.ClearContents
'結合codeからPINNOを抜きだし
Range("C2:C" & (Range("A" & (Rows.Count)).End(xlUp).Offset(-1, 0).Row)).Value = "=LEFT(RC[-2],7)"
macro_a5
End Sub
Sub macro_a5()
Sheets("work").Select
'題目
Range("C1") = "PINNO"
'複数PINNOを重複無しにする
Columns("C:C").Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"work!R1C3:R1048576C3", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="", TableName:="ActiveSheet.Name", DefaultVersion _
:=xlPivotTableVersion14
Cells(3, 1).Select
With ActiveSheet.PivotTables("ActiveSheet.Name").PivotFields("PINNO")
.Orientation = xlRowField
.Position = 1
End With
macro_a6
End Sub
Sub macro_a6()
Range("A4:A" & (Range("A" & (Rows.Count)).End(xlUp).Offset(-2, 0).Row)).Select
'Sheet5のH2セルから縦横変換でコピー貼り付け
Selection.Copy
Sheets("Sheet5").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("H5") = "=IF(ISNA(INDEX(Sheet4!R2C2:Sheet4!R30000C2,MATCH(R2C&RC5,work!R2C1:work!R30000C1,0)))=TRUE,"""",INDEX(Sheet4!R2C2:Sheet4!R30000C2,MATCH(R2C&RC5,work!R2C1:work!R30000C1,0)))"
Range("H5").Copy Destination:=Range("H5:AJ151")
Calculate
End Sub
お礼
ありがとうございました コメントアウトしたら確実に動作しました。