Excel VBA質問箱 IV

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

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


1581 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【73322】縦の並びを横の並びにしたい(行列の入れ...
質問  ブーチー  - 12/12/20(木) 11:03 -

引用なし
パスワード
  




1から6までを選んでコピーし、形式を選択して貼り付けで、行列の入れ替えをするを行うと、次のようになります。

1246

これと同じことを、セルに式が入っている場合も式を変えずに行うマクロを教えてください。

実行方法
・1から6のセルを選んでコピー
・貼り付けたいセルを選択
・マクロの実行で縦に並んでいるのもを横に並べる

例えば
=A1
=A2
=A3

実行すると、指定した場所に横に並びます。
=A1 =A2 =A3

【73323】Re:縦の並びを横の並びにしたい(行列の...
回答  ウッシ  - 12/12/20(木) 12:05 -

引用なし
パスワード
   こんにちは

地道に・・・

Sub test()
  Dim t As Range
  Dim s As Range
  Dim i As Long
  
  On Error Resume Next
  Set t = Application.InputBox("コピー元を選択", , , , , , , 8)
  If t Is Nothing Then Exit Sub
  If t.Columns.Count > 1 Then Exit Sub
  Set s = Application.InputBox("貼り付け先を選択", , , , , , , 8)
  If s Is Nothing Then Exit Sub
  If s.Rows.Count > 1 Then Exit Sub
  On Error GoTo 0
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  For i = 1 To t.Rows.Count
    s.Cells(1, i).Formula = t.Cells(i, 1).Formula
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Set t = Nothing
  Set s = Nothing
End Sub

【73324】Re:縦の並びを横の並びにしたい(行列の...
発言  UO3  - 12/12/20(木) 16:25 -

引用なし
パスワード
   ▼ブーチー さん:

前半の領域指定の部分はウッシさんのコードをほとんど拝借しています。

Sub Sample()
  Dim t As Range
  Dim s As Range
  Dim v As Variant
  
  On Error Resume Next
  Set t = Application.InputBox("コピー元を選択", Type:=8)
  If t Is Nothing Then Exit Sub
  If t.Columns.Count > 1 Then Exit Sub
  Set s = Application.InputBox("貼り付け先を選択", Type:=8)
  If s Is Nothing Then Exit Sub
  If s.Rows.Count > 1 Then Exit Sub
  On Error GoTo 0
  
  v = t.Formula
  s.Resize(, t.Rows.Count).Value = WorksheetFunction.Transpose(v)
  
End Sub

【73332】Re:縦の並びを横の並びにしたい(行列の...
お礼  ブーチー  - 12/12/21(金) 10:06 -

引用なし
パスワード
   ▼ウッシ さん 回答ありがとうございます。

コピー元をインプットboxで選択するのではなく、マウスでセルを選んでコピーし、
貼り付け先を選んでからマクロを実行というやり方は出来ないのでしょうか?

お分かりなら、教えてください。お願いいたします。

【73334】Re:縦の並びを横の並びにしたい(行列の...
お礼  ブーチー  - 12/12/21(金) 10:08 -

引用なし
パスワード
   ▼UO3 さん 回答ありがとうございます。

コピー元をインプットboxで選択するのではなく、マウスでセルを選んでコピーし、
貼り付け先を選んでからマクロを実行というやり方は出来ないのでしょうか?

お分かりなら、教えてください。お願いいたします。


>  s.Resize(, t.Rows.Count).Value = WorksheetFunction.Transpose(v)
こういう記述を身につけたいのですが、なかなか馴染めないです。

【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

【73337】Re:縦の並びを横の並びにしたい(行列の...
お礼  ブーチー  - 12/12/21(金) 16:58 -

引用なし
パスワード
   ▼ウッシ さん 回答ありがとうございます。

ココまで大変になるとは、予想してませんでした。
内容もちょっと通常とは違って理解がむずかしいです。
実用性のあるコードとして、丸ごと使わせて頂きます。

ありがとうございました。

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