ACCESS VBA　追加貼り付けが無効

Question

アクセスのVBAでエクセルのデータを編集してテーブルに追加貼り付けをしたいのですが、「追加貼り付けは無効」とポップアップが表示されてうまくいきません。
追加貼り付けのFunctionを呼び出す前のエクセルのRangeをコピーした段階で手動でテーブルに追加貼り付けをすると、追加貼り付けをします。
追加貼り付けのコードは下記のとおりですが、どこを修正すればよろしいでしょうか。

Function 追加貼り付け()
On Error GoTo 追加貼り付け_Err
 
'この下の行のacEditをacAddに変えても、追加貼り付けは無効でした。
    DoCmd.OpenTable "読み込み", acNormal, acEdit
    DoCmd.RunCommand acCmdPasteAppend

 '追加貼り付けする際に出てくるアラーム解除はこの下の行でよいのではないでしょうか。
    DoCmd.SetWarnings False


追加貼り付け_Exit:
    Exit Function

追加貼り付け_Err:
    MsgBox Error$
    Resume 追加貼り付け_Exit

End Function

DexMachina · Accepted Answer

No.2です。

AccessのTableへの貼り付け前に、シートを削除していることが原因のようです。

Excelの範囲指定でのCopy＆Pasteの場合、値そのものではなく「範囲の情報」
が、クリップボードに(?)保存されます。
そのため、貼り付け前にシートを削除したことで、「指定した範囲が見つからない
＝データがない」ということになり、「追加貼り付けは無効」となったのだと思います。
(Excel内でのCopy＆Pasteで、Copy後にシートを削除すると、Pasteができない
　のと同じ現象ではないかと)

「Call 追加貼り付け」の位置を、シート削除の前に移動することで、こちらでは
問題なく貼り付けられることを確認しました。
(「With」の中に入ることになりますが、特に問題はありません；
　「With」の宣言は『「With～End With」内にある、「.」で始まるものは、Withで
　宣言したもの(コントロール、オブジェクト他)が省略されていると見做す』という
　意味(と私は理解しています))


Sub EX_read()
On Error GoTo エラー処理

Dim EX As Excel.Application
Dim WB As Workbook
Dim WS As Worksheet
Dim WB_name As Variant
Dim Wrow As Double
Dim WB_length As Long
Dim a As Variant
Dim inti As Integer, intj As Integer

Set EX = GetObject(, "Excel.Application")
For Each WB In EX.Workbooks
   WB.Activate
   WB_name = WB.Name
   WB_length = LenB(WB_name)
   WB_name = LeftB(WB_name, WB_length - 8) '「.xls」部分を削除
   Set WS = WB.Worksheets(1)
   WS.Activate
   Wrow = WS.Range("b65536").End(xlUp).Row
   With WS
      .Range(.Cells(1, 1), .Cells(Wrow, 15)).Copy
   End With
   With WB
      .Worksheets.Add Count:=1
      With .ActiveSheet
         .Cells(1, 2).PasteSpecial Paste:=xlPasteValues
         .Cells(2, 1).Value = WB_name
         .Cells(1, 1) = "ファイル名"
         .Cells(2, 1).Copy
         .Paste Destination:=.Range(.Cells(3, 1), .Cells(Wrow, 1))
         .Range(.Cells(1, 1), .Cells(Wrow, 16)).Copy
         Call 追加貼り付け
         EX.DisplayAlerts = False
         .Delete
      End With
   End With
Next WB
Set EX = Nothing

終了処理:
   Exit Sub
エラー処理:
   MsgBox Err & "：" & Error$, , "Ex_Read": Resume 終了処理
End Sub

DexMachina · Answer

こちらで動作確認したところ、提示されたコードで、追加貼り付けは問題なく
実行されました。(WinXP＆Access2003)

> 追加貼り付けのFunctionを呼び出す前のエクセルのRangeをコピーした
> 段階で手動でテーブルに追加貼り付けをすると、追加貼り付けをします。

とのことですが、Functionを呼び出す際にも、Excel側での範囲指定＆コピー
は実行されたでしょうか。
提示されたコードにはデータをコピーする動作までは含まれていないので、
手動でのコピーを行っていないと、ご質問の通り「追加貼り付けは無効」との
メッセージが表示されます。
もう一度、確認してみて下さい。
　*Excel側のコピーも含めたコードは、私にはわかりません(汗)*


なお、SetWarningsは追加貼り付けのコマンド実行前でないと意味がないと
思います。
また、このままですと、このFunctionの実行後に、例えばうっかりテーブルや
フォーム、或いはレコードを削除した場合などにも、警告が表示されなくなって
しまいます。
ですので、「SetWarnings」をFalseに設定した場合は、「Exit Function」の前に
「DoCmd.SetWarnings True」を追加して、警告表示を復活させることをお薦めします。


Function 追加貼り付け()
On Error GoTo 追加貼り付け_Err

DoCmd.OpenTable "読み込み", acNormal, acEdit
DoCmd.SetWarnings False
DoCmd.RunCommand acCmdPasteAppend

追加貼り付け_Exit:
DoCmd.SetWarnings True
Exit Function

追加貼り付け_Err:
MsgBox Error$
Resume 追加貼り付け_Exit

End Function

fly_moon · Answer

おはようございます。
追加貼り付けがしたいのではなく、Excelのデータをテーブルに追加したいだけではないのでしょうか？
もしそうなら、コピー＆ペーストではなくインポートとクエリで対応した方が良いのではないでしょうか？

ACCESS VBA 追加貼り付けが無効

No.2です。

こちらで動作確認したところ、提示されたコードで、追加貼り付けは問題なく

この回答への補足

おはようございます。

この回答への補足

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

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

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

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

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

ACCESS VBA　追加貼り付けが無効