【Excel VBA】セル内に改行を挿入したい

質問

セル内で左から数えて10文字毎に改行（折り返し）させたいのですが、
どのようにコーディングすればよろしいでしょうか？

例）
セルA1の値が
"あいうえおかきくけこさしすせそたちつてとなにぬねの"
の場合、
"あいうえおかきくけこ
さしすせそたちつてと
なにぬねの"
としたいです。

※セルの値は、CSVから自動取得して貼り付ける仕様になっています。
　またセルの書式設定は、"折り返して全体を表示する"に事前に設定します

よろしくお願いします。

回答No.3

Wendy02 · ベストアンサー

こんばんは。

「セル内で左から数えて10文字毎に改行（折り返し）させたいのです」
「セルの書式設定は、"折り返して全体を表示する"に事前に設定します」

この二つの条件では厳密には矛盾があります。「折り返して全体を……」という設定には、改行コードは入りません。また、全角と半角の違いがありますから、全角と半角は同じようにすることは出来ません。ここでは、全角という条件にさせていただきます。

私のマクロは、先頭行の列を一回設定したら、後は、行をAutoFit（左端の色の付いたところの行の境目をダブルクリック) をすればよいだけです。列のAutoFit をしたら崩れる可能性があります。改行コードを入れたら、それも文字ですから、おそらくはずれるはずです。

これは、たぶん、アプリが持つフォントとセルの関係で、VBAでは、正しく取れない部分がある難しい種類の問題だと思います。私の技術では、今のところ、統一係数を導き出すことが出来ません。たぶん、システム上の係数はあるはずだと思います。列の幅は、8.38 という表示でしたら、半角で8.38 文字表示できるということですから、２バイト文字だったら、それを半分にすればよいと考えがちですから、セル自体に、調整スペースらしきものがあるようです。

それに、フォントの種類もあるはずです、一応、こちらでは、MSゴシック等幅フォントで試していますが、プロポーショナルでは試しておりません。うまく行かないようでしたら、解決するには、「係数」を、もう一度算出しないと出来ません。
Const dKT As String = "15,15.5,17.5,20,20.5,23,25.5"
フォントが順に8,9,10,11,12,13,14　までの対応になっていますが、しかし、これは、スタイル側のフォントが、10～12までですから、それ以外は、調整しなおさないといけません。（デフォルトは、11です)

後、なるべくなら質問の条件をひっくり返さないようにしてください。今の条件のままでしたら、調整は可能です。

'---------------------------------------------

Sub TestAutoFit()
　　Dim iFnt As Double 'スタイルフォント
　　Dim acFnt As Double　'アクティブセルフォント
　　Dim arKt As Variant
　　Dim w As Double
　　Dim strText　As String
　　'フォント定数　8～14 まで
　　Const dKT As String = "15,15.5,17.5,20,20.5,23,25.5"
　　Const iNUM As Integer = 10　'全角文字数

　　arKt = Split(dKT, ",")

　　iFnt = ThisWorkbook.Styles("Normal").Font.Size
　　If iFnt < 10 Or iFnt > 13 Then
　　　MsgBox "設定できるのは、標準スタイル・フォント10～12までで、それ以外では、" & _
　　　 "特別設定が必要です。", vbInformation
　　　Exit Sub
　　End If
　　With ActiveCell
　　strText = .Value
　　If Len(.Value) = 0 Then
　　　 MsgBox "セルが空で、実行できません。", vbInformation
　　　 Exit Sub
　　ElseIf LenB(StrConv(strText, vbFromUnicode)) = Len(strText) Then
　　　 MsgBox "半角が入っていると、現在のマクロでは調整できません。", vbInformation
　　　 Exit Sub
　　End If

　　If .WrapText = False Then
　　　　.WrapText = True
　　End If
　　 acFnt = .Font.Size
　　'スタイル・フォントは、8～14 まで。
　　If acFnt > 7 And acFnt < 15 Then
　　　　.ColumnWidth = arKt(acFnt - 8)

　　End If
　　　 .EntireRow.AutoFit
　　End With
End Sub

お礼

すみません、質問の内容をひっくり返してしまいまして、、、。私のつたない質問文章で回答者様を混乱させないように簡潔にまとめるために変更したことが、逆に皆様を混乱させてしまったかもしれません、、、。

はい、列幅は固定、フォントも指定されている状況です。
係数等、私にはちょっと難解な技術を含む問題になるんですね、、、。
このご回答は今後仕事でVBAを書き続けるであろう私にとって後々非常に有意義なものであると感じました。今はすべてを理解できずにいますが、ページを保存して永久保存させていただきたく思います。

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

回答No.5

_Kyle

今更なんですが…。

#2さんのご回答で解決しているものと思って投稿を控えていたのですが、
改めて読んでみると、どうも私の書いていたコードとは少し異なる動作をするようなので、
屋上屋を架すようですが、一応参考までに。

●動作の概要
　A1セルの値を、10文字毎に、改行コード(LF)で区切って、A1セルにセットする

●動作上の相違点(#2さんのご回答との比較)
　・文字列の最後には改行をつけない。
　・文字列が10N+1文字(1,11,21…)の場合に最後の文字を消さない。

なお、私のコードでは主処理の部分をFunctionプロシージャとして切り出しています。
実際の運用はA1セルやアクティブセルに限るわけではないでしょうし、
決まって10文字毎に区切るとも限らないので。

'=======================↓　ココカラ　↓=======================
Sub Sample090615()
　Range("A1").Value = Insdiv(Range("A1").Value, 10, vbLf)
End Sub
'--------------------
Function Insdiv( _
　ByVal orgStr As String, _
　ByVal divCnt As Long, _
　ByVal divChr As String _
　) As String
　Dim rstStr　 As String
　Dim i　　　　As Long
　If divCnt < 1 Then Insdiv = orgStr: Exit Function
　i = 1
　Do
　　rstStr = rstStr & Mid(orgStr, i, divCnt) & divChr
　　i = i + divCnt
　Loop While i <= Len(orgStr)
　Insdiv = Left(rstStr, Len(rstStr) - Len(divChr))
End Function
'=======================↑　ココマデ　↑=======================

ご参考まで。

お礼

はい、対象のセルは列は固定ですが行は不定です。
文字列の最後には改行を付けない、そうです！

応用させていただきます、ご回答ありがとうございました！

回答No.4

imogasi

参考
改行箇所で、Chｒ(10)を入れる。その位置の問題だけ。
Sub test01()
x = "あいうえおかきくけこさしすせそたちつてとなにぬねのはひふへほ"
Range("A1") = x
y = Range("A1")
s = Mid(y, 1, 10)
i = 11
p1:
s = s & Chr(10) & Mid(y, i, 10)
i = i + 10
If i < Len(y) Then GoTo p1
Range("A1") = s
End Sub
＝＝＝
（１）セルの書式設定は、"折り返して全体を表示する"に事前に設定します
（２）MSP明朝のようなプロポーショナルフォントは設定しないほうがよい。上記で最後の「ほ」が改行されたように見えておかしいなと思ったら、Pフォントが原因だった。
（３）実際はA1セルだけではないので、A列について最終行まで全行繰り返してください。コードはありふれているので略。
またGOTOを使わないループに直してください。

お礼

非常に解り易かったです。
さっそく活用させていただきました。
他の皆様の回答にもありましたが、フォントも影響するんですね。

ご回答、ありがとうございました！

回答No.2

okormazd

次のようにも、

Sub test()

Dim s As String, n As Integer, s2 As String, n1 As Integer, l As Integer

s = ActiveCell
n = Len(s)
s2 = ""
n1 = 1
l = 10

While n1 < n

s1 = Mid(s, n1, l) & Chr(10)
s2 = s2 & s1
n1 = n1 + l

Wend

ActiveCell = s2

End Sub

お礼

なるほど！と言ってもすべてを理解できたわけではないのですが、、、。こういうやり方もあるんですね。

ご回答、ありがとうございました！

回答No.1

noname#99913

文字のあるセルにカーソルを移動し、次のコードを実行してください。

Sub cut()

moji = ActiveCell.Value

mojisuu = Len(moji)

If mojisuu > 10 Then

ActiveCell.Value = ""

For i = 1 To Int(mojisuu / 10)

ActiveCell.Value = ActiveCell.Value & Mid(moji, i + (i - 1) * 9, 10)

If Mid(moji, i + 1 + i * 9, 10) <> "" Then
ActiveCell.Value = ActiveCell.Value & Chr(10)
End If

Next i

ActiveCell.Value = ActiveCell.Value & Mid(moji, i + (i - 1) * 9, 10)

End If

End Sub

お礼

ご回答いただいた内容を検証しながら応用させていただきます。

お礼コメントが遅くなり大変失礼しました。本当にありがとうございます。