ｴｸｾﾙ VBA DataObjectの不具合について

Question

前提・実現したいこと

当方VBAほぼ初心者でございます。
事務作業で使用するｺｰﾄﾞ表をｺﾋﾟﾍﾟする為、以下のｿｰｽｺｰﾄﾞを使用。

発生している問題・エラーメッセージ

近々急に下記ｴﾗｰが発症
・ｴｸｾﾙへﾍﾟｰｽﾄすると「・・」を表示
・社内ｼｽﾃﾑｿﾌﾄへﾍﾟｰｽﾄすると「？？」を表示

該当のソースコード

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A500")) Is Nothing Then
With New MSForms.DataObject
.SetText Target.Value
.PutInClipboard
End With
End If
If Not Intersect(Target, Range("D2:D500")) Is Nothing Then
With New MSForms.DataObject
.SetText Target.Value
.PutInClipboard
End With
End If
End Sub

試したこと

ﾈｯﾄ検索等でAPI関数やﾃｷｽﾄﾎﾞｯｸｽ経由のｺﾋﾟｰ等の解決方法を見ましたが、
私には複雑すぎて…ｺｰﾄﾞを何処に書けばいいかもわかりません…
すいませんが具体的にｺｰﾄﾞを教示いただけないでしょうか。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

DataObject の PutInClipboard はたまに文字化けすることがあるようです。
代替手段としては下記で紹介されている方法が一番簡単だと思います。

[VBA]DataObjectを使ったクリップボード操作が上手くいかない場合の対処法 | 初心者備忘録

上記ページから下記のコードをコピーして標準モジュールに貼り付けてください。
(ただし Private を Public に修正してます。)

Public Sub SetCB(ByVal str As String)
'クリップボードに文字列を格納
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .Text = str
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
  End With
End Sub

現状のコードを下記のように書き換えれば同じように動作します。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A500")) Is Nothing Then
        SetCB Target.Value
    End If
    If Not Intersect(Target, Range("D2:D500")) Is Nothing Then
        SetCb Target.Value
    End If
End Sub

ただし、SelectionChangeがイベントとして適切なのかは微妙、また複数範囲を選択するとエラーになります。質問とは別問題ですので深くふれませんが。

Comments

[sika3209]

hatena19様回答ありがとうございました。
上記ｺｰﾄﾞでｴﾗｰは完全に解消されました。
作業効率が全然違います!!!
本当にありがとうございました。

Answer 2

PutInClipboard

こちらの関数が怪しそうです。

Copy

に置き換えることで、解決できませんでしょうか？

参考を下記させていただきます。
※申し訳ありませんが、
動作確認までは実施しておりません。

コード参考1

With New MSForms.DataObject
.SetText Target.Value
.Copy
End With

コード参考2

[修正前]
With New MSForms.DataObject
.SetText Target.Value
.PutInClipboard
End With

[修正後]
Target.Copy

---

参考URL
https://www.redpeppers.jp/unitoro/index.php?mode=permlink&uid=6066