[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セル内の文字を，指定文字数で複数行に貼り付け』（wankon）
どうしていいか分からず，ここで質問させていただきます。
A1セルに，セル内改行付きの文章が入っています。
それを，指定文字数で区切り，B1から下に順に値を貼り付けしたいのです。
ただし，条件があり，
文の始めに「，」「。」がこないように禁則処理する。（その場合は，上のセルに一文字追加。）
また，セル内での改行「Alt+Enter」があるときは，そこから先は文字数が満たなくても次のセルに移動する。
過去の書き込みを見て，次のようなものを作ったのですが，たまに同じフレーズがあると，
無限ループしてしまいます。
「マクロ」
v = Split(Text, Chr(10))
For i = 0 To UBound(v)
ss = v(i)
Do
p = IIf(Left(ss, 1) = "・", 34, 32)
'先頭行が「・」なら全角17文字，それ以外は全角16文字で折り返す
s = StrConv(LeftB(StrConv(ss, vbFromUnicode), p), vbUnicode)
b = LenB(StrConv(s, vbFromUnicode))
If b > p Then s = Left(s, Len(s) - 1)
ss = Replace(ss, s, "")
Set MyRange = Sheets("設定").Range("A3:AR3").Find(what:=Left(ss, 1), lookat:=xlPart) '禁則処理文字一覧はRange("A3:AR3")に入力してある
If Not MyRange Is Nothing Then
s = s & Left(ss, 1)
ss = Mid(ss, 2)
Else
s = s
End If
Sheets("sheet2").Cells(1, 2).Offset(n + 1).Value = s
n = n + 1
Loop While Len(ss) > 0
Next
「マクロ終了」
さらに，値を貼り付けする前に，何行貼り付けるか数えることはできますか？
よろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
おもしろそうなテーマですが、眠いので、コードがすらっと頭に入りません。 ですので、「森を見ずに、木のみを見て」原因が本当に、文章中に同じフレーズがあって、Replace で一挙に削除され 文字列が短くなりすぎということであるなら最初（もっというなら、先頭でしょうけど）の該当文字列だけを 削除すればいいのではないですか？ 方法はいくつかあると思いますが、ややこしいのは、眠気で朦朧としていますのでシンプルなものだけでいきますと 以下、参考になりますか？
勘違いしてたらスルーしてください。
Sub Test()
Dim s As String
Dim ss As String
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
s = "あいうえお"
ss = "あいうえおかきくけこあいうえおかきくけこ"
'VBA Replace関数(無条件)
MsgBox Replace(ss, s, "")
'VBA Replace関数(最初のみ)
MsgBox Replace(ss, s, "", Count:=1)
'正規表現 Replaceメソッド
reg.Pattern = s
MsgBox reg.Replace(ss, "")
'文字列の先頭ということでよければ
'VBA MID関数
MsgBox Mid(ss, Len(s) + 1)
End Sub
で、「値を貼り付けする前に，何行貼り付けるか数えることはできますか？ 」
これも、いろんなやり方があると思いますが、直接転記せず、Redim Preserve を使いながら １次元配列に格納し、最後にその要素数を取得、転記は Worksheetfunction.Transpose を使う。 あるいは、キーをユニークにしたDictionaryのItemに格納し、最後に要素数を把握し、転記は DictionaryのItems を、同様に WorksheetFunction.Transposeで。
（β） 2015/03/21(土) 02:30
Text = "。あいうえおかきくけこさしすせそた。あいうえおかきくけこさしすせそた" & vbLf & _
"。１２３４５６７８９０１２３４５６。１２３４５６７８９０１２３４５６" & vbLf & _
"。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰ。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰ"
Sheet2の結果は以下です。
先頭に 。 が入っているのですが、よろしいのですか？
。あいうえおかきくけこさしすせそ
た。あいうえおかきくけこさしすせ
そた
0.123456789
6.123456789
56
。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯ
Ｐ。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮ
ＯＰ
以下の検索値と検索領域の関係、これでいいのですか？
Set MyRange = Sheets("設定").Range("A3:AR3").Find(what:=Left(ss, 1), lookat:=xlPart)
ちなみに、上記文字列での実行の最初、ss は
た。あいうえおかきくけこさしすせそた
その Left(ss,1) ですから What: は た になりますが？
（β） 2015/03/21(土) 07:34
＞Set MyRange = Sheets("設定").Range("A3:AR3").Find(what:=Left(ss, 1), lookat:=xlPart)
そうですね，貼り付ける領域とかぶってしまいますね。
Set MyRange = Sheets("設定").Range("A3:A10").Find(what:=Left(ss, 1), lookat:=xlPart)
のように，A列に縦に入力するように変更しました。
＞先頭に 。 が入っているのですが、よろしいのですか？
文章の先頭に「。」が入ることはないので，考えてませんでした。
途中にしか入りません。スルーして構いません。
また，ループする条件が今一自分も分かっていません。単純に同じフレーズを入れても，ループしないことの方が多い気がします。
（wankon） 2015/03/21(土) 07:46
>そうですね，貼り付ける領域とかぶってしまいますね。
いえ、貼り付ける領域は Sheet2 ですよね。検索領域は 設定 シートですから、かぶらないですよ？
気になったのは、A3〜AR3 まで、44個も禁則文字があるんだなぁということ、それはいいんですが セルに１文字ずついれているんだと思います。そうすると、１文字で１文字ずつの領域の Find ですから xlPart でもいいですけど、理屈からいえば xlWhole だなと。 で、たとえばセルに１文字ずつではなく、たとえば A3 に禁則文字を続けて１文字列として入力しておけば わざわざFind という重いものをつかわなくても InStr とか ワイルドカードの Like 比較で十分なのでは？ そういったあたりです。
要件がよくわからないのですが、先頭が ・ かという判定は、文字列全体の先頭ということですか？ それとも、分割した、それぞれの文字列の先頭ということですか？
それと、分割したものが
あああああああ 。いいいいいい
桁数は別にして、こうなったとしたら、 あああああああ は、規定通りの桁数ですが、 それを、あああああああ。 と、。を移動させることで、規定桁を超えますが、それは、それでいいのですね？
いずれにしても、お手伝いできるところがあれば、お手伝いしたいとは思います。
上のほうでコメントした、転記前に行数を把握する件、サンプルです。新規ブックでお試しください。
Sub Test2()
Dim w As Variant
Dim s As Variant
Columns("A").Clear
For Each s In Array("aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", "hhh", "iii", "jjj")
If Not IsArray(w) Then
ReDim w(1 To 1)
Else
ReDim Preserve w(1 To UBound(w) + 1)
End If
w(UBound(w)) = s
Next
MsgBox UBound(w) & " 件でした"
Range("A1").Resize(UBound(w)).Value = WorksheetFunction.Transpose(w)
End Sub
Sub Test3()
Dim dic As Object
Dim s As Variant
Columns("A").Clear
Set dic = CreateObject("Scripting.Dictionary")
For Each s In Array("aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", "hhh", "iii", "jjj")
dic(dic.Count) = s
Next
MsgBox dic.Count & " 件でした"
Range("A1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
End Sub
（β） 2015/03/21(土) 09:27
[[20140324144850]] Sub test4() Dim myText As String Dim v Dim i As Long Dim p As Long Dim ss As String, s As String Dim b As Long Dim n As Long Dim w() As String
Columns("B").ClearContents
' myText = Cells(1, "A").Text
myText = "。あいうえおかきくけこさしすせそた。あいうえおかきくけこさしすせそた" & vbLf & _
"。１２３４５６７８９０１２３４５６。１２３４５６７８９０１２３４５６" & vbLf & _
"。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰ。ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰ"
v = Split(myText, Chr(10))
For i = 0 To UBound(v)
ss = v(i)
Do
p = IIf(Left(ss, 1) = "・", 34, 32)
s = StrConv(LeftB(StrConv(ss, vbFromUnicode), p), vbUnicode)
b = LenB(StrConv(s, vbFromUnicode))
If b > p Then s = Left(s, Len(s) - 1)
ss = Replace(ss, s, "", Count:=1)
If Left(ss, 1) Like Sheets("設定").Range("A3").Value Then
' Select Case Left(ss, 1)
' Case ",", "，", "、", ".", "。"
s = s & Left(ss, 1)
ss = Mid(ss, 2)
' End Select
End If
' Cells(1, "B").Offset(n).Value = s
n = n + 1
ReDim Preserve w(1 To n)
w(n) = s
Loop While Len(ss) > 0
Next
MsgBox n & "行貼り付け"
Cells(1, "B").Resize(n).Value = WorksheetFunction.Transpose(w)
End Sub
（マナ） 2015/03/21(土) 10:49
禁則処理文字ですが，そんなに沢山無いとは思うのですが，国語の作文で文頭に来てはいけないもの，
，。」』］ゃゅょ（小さい文字）
くらいの設定で，後から付け足すことも考えて，個別にセルに入力してました。
始めに文章例を書けば良かったですね。
１つのセルに次のような文章が入っているとき，
・春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。
・夏は夜。月の頃は更なり。闇もなほ。螢の多く飛び違ひたる。
また、ただ一つ二つなど、ほのかにうち光りて行くもをかし。雨など降るもをかし。
・春はあけぼの。やうやう白くなりゆ
く山ぎは，少し明りて紫だちたる雲
の細くたなびきたる。
・夏は夜。月の頃は更なり。闇もなほ。
螢の多く飛び違ひたる。
また、ただ一つ二つなど、ほのか
にうち光りて行くもをかし。雨など
降るもをかし。
と結果を出力したいのです。
βさんので，出来ていると思うのですが，禁則文字が１つずつセルに入っている状況で，
禁則処理の簡単な書き方があれば…と思います。
また，なかなか再現が難しいのですが，無限ループに入ってしまう原因が分かりません。
よろしければ，お願いします。
（追記）
・春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。
・春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。
と１つのセルに入力したところ，無限ループではありませんが，途中が省略されて結果が出ました。
原因が分かりません。
（wankon） 2015/03/21(土) 15:59
この２行が改行コードで連結されて１セルに入っているということですね。
（マナ） 2015/03/21(土) 10:49 のマナさんのコードの myText へのセットを以下にして実行しますと
・春はあけぼの。やうやう白くなりゆ く山ぎは，少し明りて紫だちたる雲 の細くたなびきたる。春はあけぼの。 やうやう白くなりゆく山ぎは，少し 明りて紫だちたる雲の細くたなびき たる。 ・春はあけぼの。やうやう白くなりゆ く山ぎは，少し明りて紫だちたる雲 の細くたなびきたる。
このように、見事に分割されますよ。
myText = "・春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。" & vbLf & _
"・春はあけぼの。やうやう白くなりゆく山ぎは，少し明りて紫だちたる雲の細くたなびきたる。"
（β） 2015/03/21(土) 16:56
>禁則文字が１つずつセルに入っている状況で， 禁則処理の簡単な書き方があれば…と思います。
たとえば 設定 シートの A3から右に１つずつ、任意の数の禁則文字が書かれていたとします。 以下のテストでは、全角の 。 と 、 と ゃ（ちいさい ゃ） を入れてあります。
コードの最初に禁則文字群を NGchars にいれます。
で、実行時には ワイルドカードで、調べたい文字を Like比較します。 結果が True なら 禁則文字、 False なら ＯＫ文字になります。
Sub Test5()
Dim NGchars As String
Dim s As String
With Sheets("設定")
NGchars = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Range("A3", .Cells(3, Columns.Count).End(xlToLeft)))))
End With
s = "。"
MsgBox NGchars Like "*" & s & "*"
s = "ゃ"
MsgBox NGchars Like "*" & s & "*"
s = "A"
MsgBox NGchars Like "*" & s & "*"
s = "や"
MsgBox NGchars Like "*" & s & "*"
End Sub
（β） 2015/03/21(土) 17:09
＞また，なかなか再現が難しいのですが，無限ループに入ってしまう原因が分かりません
コピペの仕方を変えてみて、やっとこちらでも再現できました。 目に見えないゴミがはいっていると思われます。
Sub ゴミ取り()
ActiveCell.Value = Replace(ActiveCell.Value, ChrW(160), "")
End Sub
を実行するとOKならば、原因確定です。 その場合、コードは
ss = Replace(ss, s, "", Count:=1) を、↓に変更（βさんご提案のもう一つの方法） ss = Mid(ss, Len(s) + 1)
にするとよいでしょう。
（マナ） 2015/03/21(土) 19:53
＞ss = Mid(ss, Len(s) + 1)
これだと、ゴミは残ったままなので、別法です。
ss = v(i) の次に、↓を１行追加 ss = Replace(ss, ChrW(160), "")
（マナ） 2015/03/21(土) 22:23
みなさん，ありがとうございました！
何とか解決出来そうなので，あと少し頑張ります！
（wankon） 2015/03/22(日) 03:19
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.