エクセルのマクロ

質問

任意のセル内の文字の一部をコピー状態にした後に、任意のセルに一文字ずつ貼り付けるマクロを作成したいのですが。

例えば、A1に"あいうえお"と入力されていて、"うえお"をコピー状態にして実行すると、貼り付ける基点となるセルをインプットボックスで指定し、B3が指定されたとするなら、B3に"う"、C3に"え"、D3に"お"が貼り付けられる。

以下のマクロで望んでいる処理が可能になるのですが。

Sub test()
　Set x = Application.InputBox(Prompt:="test", Type:=8)
　　Range("A10").Select
　　ActiveSheet.Paste
　　y = Range("A10").Value
　　z = 0
　　w = Len(y)

　　　　For i = 1 To w
　　　　　x.Offset(0, z).Value = Mid(y, i, 1)
　　　　　 z = z + 1
　　　　Next i

　　Range("A10").Clear
End Sub

上記マクロでは、コピー状態になっている文字を一旦作業用のセルに貼り付けるという処置を取っていますが、そのように作業用のセルを用いないで同じ処理を行うにはどうすればいいでしょうか？

回答No.4

KenKen_SP · ベストアンサー

#1 です。

参照設定が必要ですが、こっちの方が楽かな？

Visual Basic Editor の[ツール]-[参照設定]で

　・Microsoft Forms 2.0 Object Library

にチェックを入れておきます。下記のコードで変数 strBUF にクリップボードの内容が格納されてます。

あとは、適当にセルにバラすコードを書いて下さい。

では。

Sub Sample2()

　　'要参照設定： Microsoft Forms 2.0 Object Library

　　Dim CPB　　As DataObject
　　Dim strBUF As String

　　Set CPB = New DataObject
　　With CPB
　　　　.GetFromClipboard
　　　　strBUF = .GetText
　　End With
　　Set CPB = Nothing

　　MsgBox strBUF 'クリップボードの内容を表示

End Su

お礼

ご回答ありがとうございました。
大変参考になりました。

回答No.3

misatoanna

＃２です。
書き違えてしまいました。
　R = Selection.Row
　C = Selection.Column
　For i = 1 To Len(N)
　　Cells(R, C + i - 1).Value = Mid(N, i, 1)
　Next
です。

回答No.2

misatoanna

作業用セルを別に作るのではなく、インプットボックスで指定されたセルそのものを
利用することもできますよね。

全体を　Application.ScreenUpdating = False　で画面変化を止めておいて、
ペースト後、
　　ActiveSheet.Paste
　　N = Selection.Value
　　C = Selection.Row
　　R = Selection.Column
　　For i = 1 To Len(N)
　　　　Cells(C, C + i - 1).Value = Mid(N, i, 1)
　　Next
　　Application.ScreenUpdating = True

お礼

ご回答ありがとうございました。
大変参考になりました。

回答No.1

KenKen_SP

こんにちは。KenKen_SP です。

Excel で使用されている OFFICE クリップボードは VBA で直接データを取得できません。

ご提示のコードの様に一度作業用セルを経由させるしかありません。 作業用セルへの書き込みについては、

　　Application.ScreenUpdating = False

として VBA 実行中の画面描写を停止してしまえば、ユーザーには気付かれませんが、どうしても作業用セルを使いたくないのであれば、こんな方法があります。API で直接クリップボードにアクセスしてます。

例外処理はしてませんので、適当に考えて下さい。

Option Explicit

'// クリップボードを開く
Private Declare Function OpenClipboard Lib "user32" ( _
　　　　ByVal hWndNewOwner As Long) As Long
'// クリップボードを閉じる
Private Declare Function CloseClipboard Lib "user32" () As Long
'// クリップボードのデータハンドルを取得する
Private Declare Function GetClipboardData Lib "user32" ( _
　　　　ByVal wFormat As Long) As Long
'// ヒープに確保されたメモリをロックする
Private Declare Function GlobalLock Lib "kernel32" ( _
　　　　ByVal hMEM As Long) As Long
'// GlobalLock関数によってロックしたメモリのロックを外す
Private Declare Function GlobalUnlock Lib "kernel32" ( _
　　　　ByVal hMEM As Long) As Long
'// メモリサイズを取得する
Private Declare Function GlobalSize Lib "kernel32" ( _
　　　　ByVal hMEM As Long) As Long
'// 文字列のメモリポインタから文字列を取得する(読み書き用にAny型にする）
Private Declare Function lstrcpy Lib "kernel32" ( _
　　　　ByVal lpString1 As Any, _
　　　　ByVal lpString2 As Any) As Long
'// GetClipboardData wFormat 定数
Private Const CF_TEXT = &H1

'---------------------------------------------------------------------
' @Procedure　: CB_GetText
' @Description: クリップボードの文字列を読み込むユーザー定義関数
' @Param　　　: 参照渡しの変数 strDATA に取得した文字列が格納されます
' @Return　　 : Boolean ／ 成功時：True　失敗時：False
'---------------------------------------------------------------------
Private Function CB_GetText(ByRef strDATA As String) As Boolean

　　Dim lngHDL As Long
　　Dim lngMEM As Long
　　Dim strBUF As String

　　If OpenClipboard(0&) <> 0 Then
　　　　lngHDL = GetClipboardData(CF_TEXT)
　　　　If lngHDL <> 0 Then
　　　　　　lngMEM = GlobalLock(lngHDL)
　　　　　　If lngMEM <> 0 Then
　　　　　　　　strBUF = String$(GlobalSize(lngMEM), vbNullChar)
　　　　　　　　If lstrcpy(strBUF, lngMEM) <> 0 Then
　　　　　　　　　　CB_GetText = True
　　　　　　　　End If
　　　　　　　　Call GlobalUnlock(lngHDL)
　　　　　　End If
　　　　End If
　　　　Call CloseClipboard
　　End If
　　If CB_GetText Then
　　　　strDATA = Mid$(strBUF, 1, InStr(strBUF, vbNullChar) - 1)
　　End If

End Function

Sub test()

　　Dim x As Range
　　Dim y As String
　　Dim w As Long
　　Dim z As Long
　　Dim i As Long

　　'クリップボードの文字列をString型変数yに取得してみる
　　If CB_GetText(y) Then
　　　　'取得成功
　　　　Set x = Application.InputBox(Prompt:="セルを選択", Type:=8)
　　　　If Not x Is Nothing Then
　　　　　　z = 0
　　　　　　w = Len(y)
　　　　　　For i = 1 To w
　　　　　　　　x.Offset(0, z).Value = Mid$(y, i, 1)
　　　　　　　　z = z + 1
　　　　　　Next i
　　　　End If
　　　　Set x = Nothing
　　Else
　　　　'取得失敗
　　　　MsgBox "クリップボードから文字列を取得できませんでした", vbCritical
　　End If

End Sub

お礼

ご回答ありがとうございました。
大変参考になりました。