エクセルのマクロを教えてください

右下にあるように複数セルに値があります。
最小で1個、最大で7個の値になります。
左上のように、この値を二つのセルが結合したセルに改行して入れたいです。
条件としては、
＝より右側の文字を改行して入れる
フォントはMS　Pゴシック11pt　中央揃えです。

マクロコードを解説と共に教えていただけますか？
お願いいたします。

No.3 ベストアンサー 回答者： GooUserラック 回答日時： 2019/11/11 15:35

こんなものはいかがでしょうか？

標準モジュールに以下を全て入れて下さい。
-------------------------------------------------------------------------
Dim 文字列 As String

Sub GetXX()

Dim セル As Range
Dim 頭 As Long
　文字列 = "'"
　For Each セル In Selection
　　頭 = InStr(セル.Value, "=")
　　If 頭 <> 0 Then
　　　If Len(文字列) > 1 Then 文字列 = 文字列 & Chr(10)
　　　文字列 = 文字列 & Mid(セル.Value, 頭 + 1)
　　End If
　Next

End Sub

Sub PutXX()

　With Selection
　　.HorizontalAlignment = xlCenter
　　.VerticalAlignment = xlCenter
　　.MergeCells = True
　　With .Font
　　　.Name = "ＭＳ Ｐゴシック"
　　　.Size = 11
　　End With
　　.Value = 文字列
　End With

End Sub
-------------------------------------------------------------------------

☆ 使い方

① 取り込む範囲を選択状態にして下さい
②「GetXX」を実行する
③ 貼り付け個所を選択状態にして下さい
④「PutXX」を実行する

※「文字列 = "'"」はエクセルが勝手に変な書式設定にしないようにしています。
※ 結合セルのセル高は自動で広げられません

この回答へのお礼

ありがとうございます。
カスタマイズしやすそうでとても良いです。

お礼日時：2019/11/12 10:18

No.2 回答者： WindFaller 回答日時： 2019/11/11 13:40

あくまでも、私が使うとしたら、こういうものを作っているだろう、という前提で作りました。

ですから、説明のしようがありません。いわゆるフル装備で、クリツプボードを経由して、貼り付けるスタイルです。MsgBox も、順調に進んでいる場合は、自動的に消えます。
ショートカットキーで起動しますから、以下の場合は、やりにくいのですが、
Ctrl + Alt + C でデータ格納
Ctrl + Alt + V でデータは貼り付けになります。カスタマイズできます。

たぶん、もっとわかりやすいものを作る方がいらっしゃるでしょうから、その方に譲ります。

'//標準モジュール
Option Explicit
Private objCB As Object
Private Declare Function MessageBoxTimeoutA Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long

Sub SettingKeys()
'ショートカットキー設定
'//適当にカスタマイズしてください。
'/SHIFT +/CTRL ^/ ALT %
Application.OnKey "^%c", "GetDatatoClipBoard" 'CTRL+Alt -> C
Application.OnKey "^%v", "PasteFromData" 'CTRL+Alt -> V
End Sub
Sub GetDatatoClipBoard()
'データをクリツプボードに入れる
　Dim buf As String
　Dim i As Long, c
　Set objCB = CreateObject("new:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
　If TypeName(Selection) <> "Range" Then
　　MsgBox "範囲を選択してください。", vbExclamation: Exit Sub
　End If
　For Each c In Selection
　　i = InStr(1, c.Value, ":=", 1)
　　If i > 0 Then
　　　If buf = "" Then
　　　　buf = Mid(c.Value, i + 2)
　　　Else
　　　　buf = buf & vbLf & Mid(c.Value, i + 2)
　　　End If
　　End If
　Next
　With objCB
　　.SetText buf ''変数のデータをDataObjectに格納する
　　.PutInClipboard
　　Beep
　End With
　Selection.Offset(1).Select
　MessageBoxTimeoutA 0&, "クリツプボードに格納しました", "Excel", vbMsgBoxSetForeground, 0, 2000 '2秒待ち
End Sub

Sub PasteFromData()
'ペースト
　Dim buf2 As String
　Dim Rng As Range
　Dim k As Long
　If TypeName(Selection) <> "Range" Then
　　MsgBox "セルを選択してください。", vbExclamation: Exit Sub
　End If
　Set Rng = Selection.Cells(1)
　Rng.MergeCells = False
　With Rng.Resize(2)
　　.Merge
　　.Font.Name = "MS Pゴシック"
　　.Font.Size = 11
　　.HorizontalAlignment = xlCenter
　End With
　With objCB
　　On Error Resume Next
　　.GetFromClipboard ''クリップボードからDataObjectにデータを取得する
　　buf2 = .GetText ''DataObjectのデータを変数に取得する
　　If (buf2 = "" Or Err.Number <> 0) Then MsgBox "格納したデータがありません。", vbCritical: Exit Sub
　　On Error GoTo 0
　End With
　Rng.Value = buf2
　k = Len(buf2) - Len(Replace(buf2, vbLf, ""))
　Rng.EntireRow.RowHeight = Rng.Cells(1).RowHeight * k
End Sub

Sub SetOffKeys()
'設定キーの解除
Application.OnKey "^%c", ""
Application.OnKey "^%v", ""
End Sub

No.1 回答者： fujillin 回答日時： 2019/11/11 10:34

こんにちは

エクセルのセル内改行は文字コード10の一文字です。
ですので、1行ずつに分けるならChr(10)を区切り文字として分割すれば良いです。
Split関数で配列に分割できますが、引数は0ベースになります。

仮に、元の値がA1セルにあって、分割後のn番目の文字列を求めたいとするなら、
　Split(Range("A1").Value, Chr(10))(n)
で得られますので、それぞれ「＝の前の文字列」と連結すればよさそうです。