ExcelのVBAを組みたいのですが、イマイチうまくハマりません。 A B C D E 1【日時】

解決済

質問者：おべいろん
質問日時：2020/11/27 10:35
回答数：4件

ExcelのVBAを組みたいのですが、イマイチうまくハマりません。

A B C D E
1【日時】 2020/11/25
2【名前】佐藤、田中
3
4
5
6（詳細）名前性別年齢役職
7 佐藤男 40 社員

上記のようなセルの値を1つテキストボックスにまとめてシート内に表示したいのですが、なかなか上手くいきません。

出来ない事としては
①
セルの位置関係をそのままにしてテキストボックス化
②
セルの行に空欄がある場合に上に詰めた状態でテキストボックス化

となります。

そのまま、テキストボックスを作成してコピペしても①の位置関係がズレてしまい改行も出来ない状態になってしまいます。

どなたかご教示のほどお願いいたします。

通報する

この質問への回答は締め切られました。

質問の本文を隠す

回答 (4件)

ベストアンサー優先
最新から表示
回答順に表示

No.4ベストアンサー

回答者： goomania
回答日時：2020/11/30 13:11

他のご質問者も指摘しておられますが、ご質問者のやりたい事、すでにできていること、課題となっていることが今ひとつ不明です。

ご質問者からの反応もありません。
このため、一部推測を含めて、サンプルのVBAを作成してみました。
テキストボックスの表示対象となる各セルに「セル内改行」があった場合、テキストボックス内で改行するとレイアウトが崩れてしまうので、「セル内改行」は削除する仕様です。
B2にあえて、セル内改行を含むデータを入れてテストしました。
添付画像①のデータがあったとして、このVBAを実行した結果が添付画像②です。

Sub Sample()
Dim Text_buf As String
Dim Line_buf As String
Dim i As Long
Dim j As Long
Dim Mystr As String

Text_buf = ""　　　　'---テキストボックス書込みバッファをクリア
For i = 1 To 7　　　　'---行範囲で繰り返し
Line_buf = ""　　　　'---一行分のバッファをクリア
For j = 1 To 5　　　　'---列範囲で繰り返し
Mystr = Cells(i, j).Value　　　　'---対象セルの値をMystrに代入
Mystr = WorksheetFunction.Clean(Mystr)　　　　'---セル内改行を削除
Line_buf = Line_buf & Trim(Mystr) & vbTab'---一行分のバッファにMystrの値をタブ連結で追加
Next
If Trim(Replace(Line_buf, vbTab, "")) <> "" Then'------一行分のバッファが空でなかったら
　　Text_buf = Text_buf & Trim(Line_buf)'---テキストボックス書込みバッファに一行分を追加
　　If i <> 7 Then　　　　'---最終行でなかったら
　　　　Text_buf = Text_buf & vbCrLf　　　　'---改行する
　　End If
End If
Next
Call textbox(Text_buf, "F1")'---指定セル位置にテキストボックスを作成し、テキストバッファを書き込む
End Sub

Sub textbox(str, area)
　　Dim c As Range
　　
　　For Each c In ActiveSheet.Range(area)
　　
　　　　'---指定セル位置にテキストボックスを作成し、選択する
　　　　ActiveSheet.Shapes.AddTextbox( _
　　　　　　Orientation:=msoTextOrientationHorizontal, _
　　　　　　Left:=c.Left, _
　　　　　　Top:=c.Top, _
　　　　　　Width:=c.Width, _
　　　　　　Height:=c.Height).Select

　　　　With Selection
　　　　　　.Characters.Text = str　　'---テキストに文字の内容を設定
　　　　　　.AutoSize = True　　　　　'---自動サイズ調整にする
　　　　End With
　　　　c.Select　　'---テキストボックス選択を解除
　　Next
End Sub