Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8964 / 76732 ←次へ | 前へ→

【73336】Re:縦の並びを横の並びにしたい(行列の入れ替え)
回答  ウッシ  - 12/12/21(金) 11:12 -

引用なし
パスワード
   こんにちは、ちょっと大掛かりになります。

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

295 hits

【73322】縦の並びを横の並びにしたい(行列の入れ替え) ブーチー 12/12/20(木) 11:03 質問
【73323】Re:縦の並びを横の並びにしたい(行列の入... ウッシ 12/12/20(木) 12:05 回答
【73332】Re:縦の並びを横の並びにしたい(行列の入... ブーチー 12/12/21(金) 10:06 お礼
【73336】Re:縦の並びを横の並びにしたい(行列の入... ウッシ 12/12/21(金) 11:12 回答
【73337】Re:縦の並びを横の並びにしたい(行列の入... ブーチー 12/12/21(金) 16:58 お礼
【73324】Re:縦の並びを横の並びにしたい(行列の入... UO3 12/12/20(木) 16:25 発言
【73334】Re:縦の並びを横の並びにしたい(行列の入... ブーチー 12/12/21(金) 10:08 お礼

8964 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free