実行時エラー1004ワークシートの最後から空でない新しいセルを押し出すため、新しいセルを挿入できません

Question

保存してから実行して起動するまでVBAが正常に動作していましたエラーが発生しました。

私はシート（「マスター」）からデータをコピーし、このデータをシート（「すべて」）に転記しています。問題は、（リストオブジェクトとして識別される）テーブルに変換し、貼り付けが行われる前に新しい行を追加することです。しかし何らかの理由でシートの奇妙な部分に転置します。場合によっては、必要な場所で、場合によってはExcelの最後の行にあります。このため、ランタイム1004エラーが発生し、このランダムなセルをデータで見つけなければなりません。これは私が使用するのではなくテンプレートのワークブックなので、スムーズに動作することを確認する必要があります。ここで

は私が

If Sheets("Master").Range("E3") <> "All Agents" Then 

Sheets("All").ListObjects("Table24").ListRows.Add 
    Sheets("Master").Range("E3").Copy 
    Sheets("All").Cells(Sheets("All").Range("A1").ListObject.DataBodyRange.Rows.Count + 1, 1).PasteSpecial (xlPasteValues) 
    Sheets("Master").Range("H3").Copy 
    Sheets("All").Cells(Sheets("All").Range("B1").ListObject.DataBodyRange.Rows.Count + 1, 2).PasteSpecial (xlPasteValues) 
    Sheets("Master").Range("F9:F33").SpecialCells(xlCellTypeVisible).Copy 
    Sheets("All").Cells(Sheets("All").ListObject.DataBodyRange.End(xlDown).Row, 3).PasteSpecial xlPasteValues, Transpose:=True 

Answer 1

Option Explicit 

Sub Macro1() 
    Dim wsm As Worksheet, i As Long, v As Long, vals As Variant 

    Set wsm = Worksheets("Master") 
    If LCase(wsm.Range("E3")) <> "all agents" Then 
     v = Application.Subtotal(103, wsm.Range("F9:F33")) 
     If CBool(v) Then 
      ReDim vals(1 To 1, 1 To v + 2) 
      vals(1, 1) = wsm.Range("E3").Value 
      vals(1, 2) = wsm.Range("H3").Value 
      For i = 1 To v 
       vals(1, i + 2) = wsm.Range("F9:F33").SpecialCells(xlCellTypeVisible)(i) 
      Next i 

      With Worksheets("All").ListObjects("Table24") 
       .ListRows.Add AlwaysInsert:=False 
       .DataBodyRange.Cells(.DataBodyRange.Rows.Count, 1).Resize(1, UBound(vals, 2)) = vals 
      End With 
     End If 
    End If 
End Sub 

、としてそれを試してみてくださいを使用していたコードです