| |
こんにちは、ちょっと大掛かりになります。
U03さんのコードもお借りして、標準モジュールの先頭から下記コードを貼り付けてから
マクロ「test1」をショートカットキーに割り当てて下さい。（例えば、Ctrl+Shift+U）
コピー元セルを選択し「Ctrl+C」でコピーし、貼り付け先セルを選択して、「Ctrl+Shift+U」で実行してみて下さい。
Option Explicit
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Sub test1()
Dim t As Range
Dim s As Range
Dim r As String
Dim i As Long
On Error Resume Next
r = GetCopyAddress
r = RTrim(r)
r = Mid(r, InStrRev(r, " ") + 1, Len(r))
r = Application.ConvertFormula(r, xlR1C1, xlA1)
Set t = Range(r)
If t Is Nothing Then
MsgBox r
Exit Sub
End If
If t.Columns.Count > 1 Then Exit Sub
Set s = Selection
If s Is Nothing Then Exit Sub
If s.Rows.Count > 1 Then Exit Sub
s.Resize(, t.Rows.Count).Value = WorksheetFunction.Transpose(t.Formula)
Set t = Nothing
Set s = Nothing
End Sub
Public Function GetCopyAddress() As String
Dim i As Long
Dim lngFormat As Long
Dim hMem As Long
Dim p As Long
Dim strData() As Byte
Dim lngSize As Long
Dim strAddress As String
Call OpenClipboard(0)
hMem = GetClipboardData(RegisterClipboardFormat("Link"))
If hMem = 0 Then
Call CloseClipboard
GetCopyAddress = "コピー実行選択セル無し"
Exit Function
End If
lngSize = GlobalSize(hMem)
p = GlobalLock(hMem)
ReDim strData(0 To lngSize - 1)
Call MoveMemory(VarPtr(strData(0)), p, lngSize)
Call GlobalUnlock(hMem)
Call CloseClipboard
For i = 0 To lngSize - 1
If strData(i) = 0 Then
strData(i) = Asc(" ")
End If
Next i
GetCopyAddress = AnsiToUnicode(strData())
End Function
Private Function AnsiToUnicode(ByRef strAnsi() As Byte) As String
On Error GoTo ErrHandler
Dim lngSize As Long
Dim strBuf As String
Dim lngBufLen As Long
Dim lngRtnLen As Long
lngSize = UBound(strAnsi) + 1
lngBufLen = lngSize * 2 + 10
strBuf = String$(lngBufLen, vbNullChar)
lngRtnLen = MultiByteToWideChar(0, 0, strAnsi(0), lngSize, StrPtr(strBuf), lngBufLen)
If lngRtnLen > 0 Then
AnsiToUnicode = Left$(strBuf, lngRtnLen)
End If
ErrHandler:
End Function
|
|
ウッシ
- 12/12/21(金) 11:12 -
