3つのプロシージャをまとめたら実行時エラー発生で対応不能

Question

順を追って具体的に説明致します。

添付画像は、Sheet3の体裁です。
C列1で日付・2で時間・3で約定値・4で出来高をアドインソフトにてリアルタイルに取込でいます。
そして、CDE列各々の12行目から最終行の下空白行へ取込データを入力して行きます。
A列の12行目からは同じ行のC列にデータが有れば、上の行の値に+１して書込み
そのMax値がA9に表示され「作業中行数」と名付けました。
J9は「T設定行数」と名付け、CDE列へ入力されて行く目標行数を表し
その数に応じて、J～O列12行のセル関数で値を算出。
ここまでの処理を
Private Sub Worksheet_Calculate()で書きました。

A9「作業中行数」がJ9「T設定行数」以上に成ったら
J～O列12行のセルの値を
同じbookのSheet2のA～F列の、最終行の下空白行へ
先に開いて置いたファイル(book)のSheet計算のB～G列の、最終行の下空白行へ
各々転記する。
ここまでの処理を
Sub 指定したシートとセル領域にデータ転記()で書きました。

前述の各々の転記が終わったら
C列12行目からE列のJ9(T設定行数)+11行目迄を削除して
C～E列のJ9(T設定行数)+11行目の次の行以降を
12行目迄シフトアップさせる。
このシフトアップは、画像でも確認頂けますが、1秒間に2行以上一気にデータ入力される事が多々あり、取りこぼしを防げると思いそうしました。
ここまでの処理を
Sub 削除後に上方にシフト()で書きました。

シフトアップ後は、再びデータが入力されて行き、
設定行数に達したら、各々へデータの転記、削除・シフトアップ
を、ファイルを閉じるまで、繰り返す様になると思うのですが、分かりません。
その様にしたいです。

ここまでが、完成した時の概略を説明致しました。

　因みに起動の順番は、真っ先にリアルタイムに取込む為のエクセルへのアドインソフトを起動
次に、転記させたいファイル(Sheet計算の有るbook)を
最後に、このVBAを書いているファイル(book)をダブルクリック・「更新する」クリックで開きます。

書いたVBAは、以下の如です。
このVBAは、Microsoft Excel ObjectsのSheet3に書いています。

Private Sub Worksheet_Calculate()
    Dim myData1
    Dim myData2
    Dim myData3
     myData1 = Worksheets("Sheet3").Range("C3").Value  '現在値のRSS取込データ
     myData2 = Worksheets("Sheet3").Range("C2").Value  '時刻のRSS取込データ
     myData3 = Worksheets("Sheet3").Range("C1").Value  '日付のRSS取込データ

If Range("C4") > Range("D4") Then   'C4セル(取引毎に出来高が更新され、
				'それに応じて現在値・日付・時刻も更新される。
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    With Worksheets("Sheet3")
            n = Cells(Rows.Count, "E").End(xlUp).Row + 1
            .Range("E" & n).Value = myData1
    End With
以下2つWith～End Withが有りますが、構文は上と同じ(1つは"D"・もう1つは"C")なので省略します。

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End If
  Call 指定したシートとセル領域にデータ転記
End Sub
「このプロシージャのみでは、ファイルを閉じるまで、取込に有力続けます。」
-------------------------------
Sub 指定したシートとセル領域にデータ転記()
If Worksheets("Sheet3").Range("A9").Value >= Worksheets("Sheet3").Range("J9").Value Then
「このプロシージャ内にカーソルを置きF5を押せば、各々への転記後に削除・シフトアップします。」
  Dim ws2 As Worksheet
  Dim ws3 As Worksheet
          Dim 受ws As Worksheet    
  Dim 最終行の下A
          Dim 受最終行下B

  Set ws3 = Worksheets("Sheet3")
  Set ws2 = Worksheets("Sheet2")
          Set 受ws = Workbooks(1).Worksheets("計算")

   最終行の下A = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
   ws2.Range("A" & 最終行の下A).Value = ws3.Range("J12").Value
以下5つ同じ構文が有りますが、省略します。

　　  受最終行下B = 受ws.Cells(Rows.Count, "B").End(xlUp).Row + 1
        受ws.Range("B" & 受最終行下B).Value = ws3.Range("J12").Value
以下5つ同じ構文が有りますが、省略します。
  Call 削除後に上方にシフト
End If
End Sub
-----------------------
Sub 削除後に上方にシフト()
     Dim gyou
      gyou = Worksheets("Sheet3").Range("J9").Value
      Worksheets("Sheet3").Range("C12:E" & gyou + 11).Delete xlShiftUp

「以下は、削除によってセルに記述していた関数が 「 #REF!」と成った為
対象のセルに関数を書き込む様にしました。」
   Worksheets("Sheet3").Range("J12").Value = "=IF($C$12="""","""",$C$12)"
   Worksheets("Sheet3").Range("K12").Value = "=IF($D$12="""","""",$D$12)"
   Worksheets("Sheet3").Range("L12").Value = "=IF($E$12="""","""",$E$12)"
   Worksheets("Sheet3").Range("M12").Value = "=MAX($E$12:OFFSET($E12,$J$9-1,0))"
   Worksheets("Sheet3").Range("N12").Value = "=MIN($E$12:OFFSET($E12,$J$9-1,0))"
   Worksheets("Sheet3").Range("O12").Value = "=OFFSET($E12,$J$9-1,0)"
   Worksheets("Sheet3").Range("A9").Value = "=MAX(A12:A211)"
   Worksheets("Sheet3").Cells(12, 1) = "=IF($C12="""","""",1)"
   Worksheets("Sheet3").Cells(13, 1).Resize(199, 1).FormulaR1C1 = "=IF(RC3="""","""",R[-1]C+1)"
End Sub

 以上の内容で、先の手順の如く実施致しました処
Sub Worksheet_Calculate()でデータが入力されて行き
A9(作成中行数)がJ9(設定行数)と同じ75に成った時に
「実行時エラー'-2147417848(80010108)': 'Range'メソッドは失敗しました'-Worksheet'オブジェクト」のダイアログ出現しました。
デバッグをクリックすると
myData1 = Worksheets("Sheet3").Range("C3").Valueの行が黄色に反転表示
myData1にカーソルを重ねると、「= Empty値」とコメント表示される
しかしSheet3のC3セルを見るとRSSで値は更新変化していました。

解決方法が見出ださません。
エクセルは2013・OSはWindows10です。
どうか宜しく、お教え下さいませ。

Qchan1962 · Accepted Answer

＃４で回答した者です
＃３様の回答で解ける出来ると存じますが・・・

Application.Calculation = xlCalculationAutomatic
について追記します。
Application.Calculation = xlCalculationAutomatic
終了時に自動再計算に戻す（手動のままでいいのであれば、記述は不要）
戻した場合、再度Worksheet_Calculate()が実行されますので
Application.EnableEvents = Trueのコードより前に実行する必要があります。

流石にローカルで試してみました（コードを読むだけでは限界が・・・）
実際に不明のコードは考えず、参考の為、纏めてみました
一応記します
Option Explicit

Private Sub Worksheet_Calculate()
    Dim myData1
    Dim myData2
    Dim myData3
    Dim n As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Worksheets("Sheet3")
        myData1 = .Range("C3").Value    '現在値のRSS取込データ
        myData2 = .Range("C2").Value    '時刻のRSS取込データ
        myData3 = .Range("C1").Value    '日付のRSS取込データ
        If .Range("C4") > .Range("D4") Then    'C4セル(取引毎に出来高が更新され、
            'それに応じて現在値・日付・時刻も更新される。
            n = .Cells(Rows.Count, "E").End(xlUp).Row + 1
            .Range("E" & n).Value = myData1
            '以下2つWith～End Withが有りますが、構文は上と同じ(1つは"D"・もう1つは"C")なので省略します。
            
        End If

If .Range("A9").Value >= .Range("J9").Value Then
        Call 指定したシートとセル領域にデータ転記 '標準モジュールに記す場合、モジュールオブジェクト名を加えてください
'        Call Module1.指定したシートとセル領域にデータ転記 '　Module1記載例
        End If
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub
'「このプロシージャのみでは、ファイルを閉じるまで、取込に有力続けます。」
'-------------------------------
Sub 指定したシートとセル領域にデータ転記()
    '「このプロシージャ内にカーソルを置きF5を押せば、各々への転記後に削除・シフトアップします。」
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim 受ws As Worksheet
    Dim 最終行の下A As Long
    Dim 受最終行下B As Long

Set ws3 = Worksheets("Sheet3")
    Set ws2 = Worksheets("Sheet2")
    Set 受ws = Workbooks(1).Worksheets("計算")

最終行の下A = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    ws2.Range("A" & 最終行の下A).Value = ws3.Range("J12").Value
    '以下5つ同じ構文が有りますが､省略します｡

受最終行下B = 受ws.Cells(Rows.Count, "B").End(xlUp).Row + 1
    受ws.Range("B" & 受最終行下B).Value = ws3.Range("J12").Value
    '以下5つ同じ構文が有りますが､省略します｡

With ws3
        .Range("C12:E" & .Range("J9").Value + 11).Delete xlShiftUp
        '「以下は、削除によってセルに記述していた関数が 「 #REF!」と成った為
        '対象のセルに関数を書き込む様にしました。」
        .Range("J12").Value = "=IF($C$12="""","""",$C$12)"
        .Range("K12").Value = "=IF($D$12="""","""",$D$12)"
        .Range("L12").Value = "=IF($E$12="""","""",$E$12)"
        .Range("M12").Value = "=MAX($E$12:OFFSET($E12,$J$9-1,0))"
        .Range("N12").Value = "=MIN($E$12:OFFSET($E12,$J$9-1,0))"
        .Range("O12").Value = "=OFFSET($E12,$J$9-1,0)"
        .Range("A9").Value = "=MAX(A12:A211)"
        .Cells(12, 1) = "=IF($C12="""","""",1)"
        .Cells(13, 1).Resize(199, 1).FormulaR1C1 = "=IF(RC3="""","""",R[-1]C+1)"
    End With

Set ws3 = Nothing
    Set ws2 = Nothing
    Set 受ws = Nothing

End Sub

fujillin · Answer

No3です。

＞コンパイルエラー,Ifブロックに対応するEnd Ifが有りません」のダイアログが出現。
ごめんなさい。
質問文のコードが、コメントや説明がごちゃ混ぜなので、
＞If Range("C4") > Range("D4") Then
を見落としてしまいました。
その部分に関しては、当方の誤りです。

いろいろと試していらっしゃるようですが、意図がわかりかねますし、文章を読んでも説明がよくわかりません。
推測しているのは、
・セルを削除移動により計算が発生する
・セルに関数式を記入することにで計算が発生する
ことによるオバーフローです。
ですので、ご提示の処理を実行する際にイベント発生を抑制しておけば、少なくともオーバーフローは発生しないと推測しているのですが・・・

No3の回答はそういう意味ですけれど、そのような制御に修正して試していらっしゃいますか？

Qchan1962 · Answer

#1 です（ご質問コード）多分、元凶は数式を書き込むところで自動計算が実行される事で＃３様のイベントを止めいる状態で書き込むことで対応できるかと思います必要であれば Application.ScreenUpdatingなどと共に Application.Calculation = xlCalculationManual 計算を手動にする Application.Calculation = xlCalculationAutomatic 終了時に自動再計算に戻す（手動のままでいいのであれば、記述は不要）を加えてみてください。（現状）＞Sub 指定したシートとセル領域にデータ転記()は作動しませんでした。これは、＞各々への転記・削除・シフトアップの処理が行われ、とあるので、実行されているものと判断します。出力されないのは、条件に問題があるか、参照先の値が同じ値などと推測します。F5実行ではなくF8の繰り返しで実行して確認してください。（改修などをする場合）処理全体が見えないので難しいのですが、トリガー（処理開始起点）はアドインからの書き込みでしょうか？ CalculateにはTargetが有りませんので Worksheet_Calculate　を　Worksheet_Changeなどに変更する事は可能ですか？可能ならば、トリガーセルをTargetで限定して処理が足るようにするのはどうでしょうか？あと、 Sub 削除後に上方にシフト()　は数式入力ではなく結果の値入力に書き換える事は可能ですか？一応、数式入力部分をVBAで計算するように書いて見ましたが、 OFFSETで使われているJ9セルの変化で抽出する値は、自動ででなくなるのでWorksheet_Changeなどを使い計算VBAを実行する必要があります。まあ、ここはロジックを変える場合の参考程度での話です With Worksheets("Sheet3") If .Range("C12") <> "" Then .Range("J12") = .Range("C12") Else .Range("J12").Value = "" If .Range("D12") <> "" Then .Range("K12") = .Range("D12") Else .Range("K12").Value = "" If .Range("E12") <> "" Then .Range("L12") = .Range("E12") Else .Range("L12").Value = "" .Range("M12").Value = Application.Max(.Range("E12").Resize(.Range("J9"), 1)) .Range("N12").Value = Application.Min(.Range("E12").Resize(.Range("J9"), 1)) .Range("O12").Value = .Range("E12").Offset(.Range("J9") - 1, .Range("E12") - 1) If .Cells(12, 1) = "" Then .Cells(12, 1) = "" Else .Cells(12, 1) = 1 If .Cells(12, 1) <> "" Then i = 2 For Each targetCell In .Cells(13, 1).Resize(199, 1) If targetCell.Offset(, 2) <> "" Then targetCell.Value = i i = i + 1 Else targetCell.Value = "" End If Next End If .Range("A9").Value = Application.Max(.Range("A12:A211")) End With

fujillin · Answer

No2です。

＞白紙である「標準モジュール」に貼り付けてみました
どこからそのようなことになったのか不明ですけれど、メモリーには関係ないと思います。

＞諦めるしかないのでしょうか。
不明点が多いので、コードを追いかける気にはならないため、内容はわかりませんけれど・・

以下のようにしてもダメでしょうか？

Private Sub Worksheet_Calculate()
Dim myData1
Dim myData2
Dim myData3

Application.EnableEvents = False
Application.ScreenUpdating = False

myData1 = Worksheets("Sheet3").Range("C3").Value '現在値のRSS取込データ
myData2 = Worksheets("Sheet3").Range("C2").Value '時刻のRSS取込データ
myData3 = Worksheets("Sheet3").Range("C1").Value '日付のRSS取込データ
With Worksheets("Sheet3")
n = Cells(Rows.Count, "E").End(xlUp).Row + 1
.Range("E" & n).Value = myData1
End With
’End If　　←　**** いきなり End If だけあるので文法的におかしい ???*****
Call 指定したシートとセル領域にデータ転記

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

＞希望している動作に成らないという事は間違っているのですが
処理内容は見ていませんので、ご希望の動作かはわかりませんけれど、ご質問文にあるエラーは出なくなりませんか？

fujillin · Answer

こんにちは

ご説明の内容が複雑にすぎるので、全く理解できませんけれど・・
雰囲気からの想像ですが、イベント処理でオーバフローしているのではないでしょうか？

以下でも、同様のエラーが簡単に発生します。
シートモジュールに以下を記述の上、test_calc()を直接実行。

Private Sub Worksheet_Calculate()
Dim a
a = Range("A1").Value
Call test_calc
End Sub

Sub test_calc()
Range("B1").FormulaLocal = "=A1&""B"""
End Sub

ご提示のコードにすでに記述はありますが、イベントの発生をきちんと制御することで対処できるのものと思います。

Qchan1962 · Answer

こんにちは
実行時エラー'-2147417848(80010108)': 'Range'メソッドは失敗しました'
このエラーは、アプリケーション側のエラーのようです
負荷が高い処理を行うと起こりやすいようなので沼が深いかも知れません
問題を具体的に示す事は難しいので取り敢えず、処理負荷を減らす
コード、ロジックに変更する事が有効かもしれません。

未検証(ざっくり)なので具体的添削はやめときますが
数式を書き込むところで一旦自動計算を止め、纏めて再開とか

End Sub
-----------------------
Sub 削除後に上方にシフト()
これについては1つのプロシージャにした方がメモリ負担は減るかも知れません

With　オブジェクト　で同じオブジェクトに対して行う処理を
纏めるとか・・・
アドイン動作を考慮して適所に　DoEventsなどを入れるとか・・
ロジック自体変更して、
Worksheet_Calculateでループするような事をやめ
別のトリガーを考えるとか・・・
適当に上げても仕方ありませんが取り敢えず・・

3つのプロシージャをまとめたら実行時エラー発生で対応不能

＃４で回答した者です

No3です。

#1 です

No2です。

こんにちは

こんにちは

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング