ＥＸＣＥＬでフォームのテキストBOXに入力した文章を別セルに書き出すマ

質問

ＥＸＣＥＬでフォームのテキストBOXに入力した文章を別セルに書き出すマクロ

Excel VBAでフォームのテキストBOXに入力した文章を別セルに書き出すマクロを作成しています。

普通に書き出すことと、改行コードで改行させることはできます。
しかし、改行コード＆決まった文字数（任意）で改行し、改行後の先頭に句読点が来たときには句読点で改行させるようにしたいです。
（句読点が行末に来る場合、任意の文字数に＋１する）

どのようにしたら良いでしょうか？
今行っている方法だと、１行で文字数での改行が２回行われるとおかしくなってしまいます。
ご教授ください

回答No.1

keithin · ベストアンサー

必要な仕事を丁寧に。

作成例：
Private Sub CommandButton1_Click()
　Dim a As Variant
　Dim LineLength As Long
　Dim i, j

　’決まった文字数の指定
　LineLength = 9

　a = Split(TextBox1, vbLf)
　For i = 0 To UBound(a)
　　j = LineLength

　　Do Until j > Len(a(i))

　　　’句読点の指定。連続した句読点の検出
　　　Do While Mid(a(i), j + 1, 1) Like "[,、，、.。．。?!？！]"
　　　　j = j + 1
　　　Loop

　　　a(i) = Application.Replace(a(i), j + 1, 0, vbLf)
　　　j = j + 1 + LineLength
　　Loop
　Next i
　Cells(1, 1) = Join(a, vbLf)

End Sub

お礼

回答ありがとうございました
本日自分の作成した物の中に組み込みまして、動作を確認しました。
自分の中では句読点は”。”と”、”しか考えていなかったので、目からウロコでした。
一番早かったのと、非常に読みやすいマクロだったのでベストアンサーとさせていただきました。
ありがとうございました。

回答No.2

Wendy02

>今行っている方法だと、１行で文字数での改行が２回行われるとおかしくなってしまいます。
どのようにしているのか、言葉では、よく分かりません。

>Excel VBAでフォームのテキストBOXに入力した文章を別セルに書き出すマクロを作成しています。
フォームというのは、UserForm のことだとは思いますが、セルに書き出すということで、セルに一行を割り当てることにしました。Excelの本来の機能の「分割」にありますから、これ自体はあまり意味がありませんが、そうでない場合は、一部を書き換えることによって、1セルに入れることも可能です。見栄えがあまり良くありません。

なお、意図的に、「、あいうえお」と入れられた文章は、「、」が分離されてしまいます。
また、全角・半角の区別がついていません。だから、半角文字での出力では、文字数は合っていても、バランスは取れていません。英字のワードラップはされません。それから、TextBox の中のEnterコードは、Cr + Lf になっています。

'//
Private Sub commandbutton1_Click()
　Dim iKeta As Long
　Dim buf As String, buf2 As String, buf3 As String
　Dim i As Long, v As Variant
　Dim Ar As Variant, ArBuf As Variant

　'桁の設定
　iKeta = 20　　'Val(TextBox2.Value)　'TextBox2 から取る場合
　If iKeta = 0 Then Exit Sub
　If Len(TextBox1.Value) < 2 Then
　　MsgBox "文書がありません。", vbExclamation
　　Exit Sub
　Else
　　buf = TextBox1.Value
　End If
　Ar = Split(buf, vbCrLf)
　For Each v In Ar
　　For i = 1 To Len(v) Step iKeta
　　　If StrConv(Mid$(v, i, 1), vbWide) Like "[、。）]*" Then
　　　　buf2 = buf2 & Mid$(v, i, 1) & vbLf & Mid$(v, i + 1, iKeta)
　　　　i = i + 1
　　　Else
　　　　buf2 = buf2 & vbLf & Mid$(v, i, iKeta)
　　　End If
　　Next
　　buf3 = buf3 & vbLf & buf2
　　buf2 = ""
　Next
　ArBuf = Split(Mid$(buf3, 3), vbLf)
　ActiveCell.Resize(UBound(ArBuf) + 1) = Application.Transpose(ArBuf)
　Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column)).WrapText = False
End Sub

'Private Sub UserForm_Initialize()
''TextBox1 のプロパティが変更されていない場合
'　With Me.TextBox1
'　.MultiLine = True
'　.EnterKeyBehavior = True
'　End With
'End Sub

お礼

回答ありがとうございます。
Textboxのプロパティまで気に掛けて頂いてありがとうございます
回答に気が付いたのが帰宅後だったので、試せませんが、後日確認して勉強させていただきます。
ありがとうございました