VBAにて空白や改行があれば動作を行う

Question

Public Sub 抽出()
   Dim a() As String, b As String
   Dim v As Variant
   Dim i As Long, j As Long
   Const c As String = " "

   Application.ScreenUpdating = False
   'D2から最終行まで探す
   For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    'Dのテキストを格納する
    b = WorksheetFunction.Clean(Cells(i, "D").Text)
    b = Replace(b, c, "")
     '記号の次
      For Each v In Array("。")
         b = Replace(b, v, c, , , vbTextCompare)
      Next
      a = Split(WorksheetFunction.Trim(b), c)
     '0行目から最終行まで
      For j = 0 To UBound(a)
      'もし文頭が記号から始まれば1文字のみ取る
      If Left(a(j), 1) = "『"  Then
         a(j) = Left(a(j), 1)
      End If
         a(j) = Left(a(j), 2)
      Next
     'Eからみぎのセルに貼り付ける
      Cells(i, "E").Resize(, j).Value = a
   Next
   Application.ScreenUpdating = True
End Sub

セルにある文章を一行ずつ探して、
「。」の次から始まる言葉を抽出するというマクロなのですが、
「。」だけじゃなくて改行や空白があったらその次の文章からも取りたいのです。

現状だと
～。●●～～～
○○～～～。▲▲...
とあった場合、●●と▲▲は取れるんですけど○○は取得できない感じです。

   For Each v In Array("。", " ", " ", "vbCrLf")

ここにこういう風に足せばいいのでは？と思ったのですが全く違うようでした。
半角スペース、全角スペース、改行のあと という処理はどのように行えばいいのでしょうか。

Answer 1

まず、提示いただいたソースは正しく動作するものでしょうか？
セルの文字列を配列の変数aに格納していたり、splitした結果を配列ではない変数bに格納していたりして、私の環境では動作しませんでした。

下記のように動作するコードに修正したコードをベースにアドバイスさせていただきます。

Public Sub 抽出()
   'Dim a() As String, b As String
   Dim a As String, b() As String
   Dim v As Variant
   Dim i As Long, j As Long
   Const c As String = " "

   Application.ScreenUpdating = False
   'D2から最終行まで探す
   For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    'Dのテキストを格納する
    a = WorksheetFunction.Clean(Cells(i, "D").Text)
    a = Replace(a, c, "")
     '記号の次
      For Each v In Array("。")
         a = Replace(a, v, c, , , vbTextCompare)
         
      Next
      b = Split(WorksheetFunction.Trim(a), c)
     '0行目から最終行まで
      'For j = 0 To UBound(a)
      For j = 0 To UBound(b)
      'もし文頭が記号から始まれば1文字のみ取る
      If Left(b(j), 1) = "『"  Then
         b(j) = Left(b(j), 1)
      End If
         b(j) = Left(b(j), 2)
      Next
     'Eからみぎのセルに貼り付ける
      Cells(i, "E").Resize(, j).Value = b
   Next
   Application.ScreenUpdating = True
End Sub

処理の流れについて

まず、元ソースの処理の流れを正しく理解するところから始めましょう。

元ソースが行っている処理は「D列のセルから取得した文字列より、"。"の後に出現する2文字を取得し表示する」という内容です。

置換処理の流れ（１セルの内容を置換・分解する仕組み）をざっくりあげると
①D列のセルを1つ取り出して変数aに格納する
②変数aに含まれる半角スペースを空文字""に置換する（半角スペースの除去）
③変数aに含まれる文字列"。"を半角スペースに置換する
④変数aを半角スペースで分解し、結果を配列bに格納する
⑤配列bの各要素に対し、（"『"で始まる場合は先頭1文字を除去してから）先頭2文字を取得し、セルに表示する

といった流れで処理をしています。

重要な部分を開設すると、
④で行うSplitは、与えられた文字列(変数a)を指定した１文字(変数c=半角スペース)ごとに区切った文字列配列を返します。
今回の場合、"。"という全角1文字を指定して区切ることもできるのですが、2文字以上の文字列（例えば"?!"）で分割することはできません。
そういった場合、事前準備として③で行っているように変数aの中の"。"を特定の区切り文字（変数c=半角スペース）に置換してからSplitします。

この際、もともとセルから取得した内容に半角スペースが含まれていると、"。"を置き換えた半角スペースだけでなく、もとからある半角スペースでも区切られてしまいます。
これを避けるため、さらに事前準備として②の処理で半角スペースを除去している、というわけです。

改修内容について

上記を踏まえて、さらに全角スペース、半角スペース、改行文字でも区切りたいというのが今回の目的です

まず、半角スペースで区切りたいのに、②の処理で事前に半角スペースを除去してしまうのは問題がありますよね。
なので②の処理は不要ということになります。
加えて、半角スペース⇒半角スペースへの置換も無意味ですので、区切り文字のarrayにも半角スペースは不要ということになります。

改行文字についてはynakanoさんからも指摘があるとおり、""で括っていることが誤りです。
これでは変数aの文字列の中から改行ではなく"vbCrLf"という文字列を探すことになってしまいます。

これらを修正すれば、目的の動作となるのではないでしょうか。

わかりやすいコードにするために

今回のソースは、処理内容にコメントをつけてはありますが、変数名が雑すぎて非常に処理内容が掴みにくいコードになっています。
私も普段目にしているコードに比べて、このコードを理解するのには倍以上の時間が掛かりました。

aの中のcをreplaceする・・・aってなんだっけ？cってなんだっけ？といった具合です。
例えばa⇒sEditText、c⇒cSpaceだったりすれば、なんだっけ？となる回数が減り、コード理解がしやすくなります。

サンプルコード

Public Sub 抽出()
   Dim sEditText As String, aryText() As String
   Dim vDiv As Variant
   Dim i As Long, j As Long
   Const cSpace As String = " "

   Application.ScreenUpdating = False
   'D2から最終行まで探す
    For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
        'Dのテキストを格納する
        sEditText = WorksheetFunction.Clean(Cells(i, "D").Text)
        ''半角スペースを除去する
        'sEditText = Replace(sEditText, cSpace, "")
        
        '記号の次
        For Each vDiv In Array("。"," ",vbCrLf)
            '指定文字を半角スペースに置換する
            sEditText = Replace(sEditText, vDiv, cSpace, , , vbTextCompare)
        Next
        
        '半角スペースで分割する
        aryText = Split(WorksheetFunction.Trim(sEditText), cSpace)
        
        '0行目から最終行まで
        For j = 0 To UBound(aryText)
            'もし文頭が記号から始まれば1文字除去する
            If Left(aryText(j), 1) = "『"  Then
                aryText(j) = Left(aryText(j), 1)
            End If
            aryText(j) = Left(aryText(j), 2)
        Next
        
        'Eからみぎのセルに貼り付ける
        Cells(i, "E").Resize(, j).Value = aryText
    Next
   Application.ScreenUpdating = True
End Sub

参考になれば幸いです。

Comments

[dokoniarukana]

懇切丁寧に解説して頂きありがとうございました。
自分で作ったソースならなおさらのこと、今回はそうではなく理解が不十分でした。
分からないことが多かったのできちんと意味を知って次回に生かそうと思います。

Answer 2

「。」、半角スペース、全角スペース、改行で Split して取得した配列の各要素の先頭を取れば良いのでは？

現状だと

～。●●～～～
○○～～～。▲▲...
とあった場合、●●と▲▲は取れるんですけど○○は取得できない感じです。

不明点は改行後の先頭の文字が取得できないと言うことでよろしいでしょうか。

    Dim s As String
    Dim arr() As String
    Dim i As Integer
    
    s = Cells(2, "D").Text
    
    s = Replace(s, " ", "。")
    s = Replace(s, "　", "。")
    s = Replace(s, vbCrLf, "。")
    s = Replace(s, vbLf, "。")
    s = Replace(s, vbCr, "。")
    
    arr = Split(s, "。")
    
    For i = 0 To UBound(arr)
        Cells(2, i + 5).Value = arr(i)
    Next

こうすると D2 の値が「。」、半角スペース、全角スペース、改行
で分割されて E2, F2, G2 ... に表示されますがヒントになるでしょうか。

Comments

[dokoniarukana]

>Split して取得した配列の各要素~
がよく分かっていませんでしたがこういうことだったのですね。
参考にさせて頂きます。

Answer 3

vbCrLfをダブルクォーテーションで囲ってしまうと「vbCrLf」という文字列として解釈されるのではないでしょうか？

Comments

[dokoniarukana]

vbCrLfのみで試してみましたがやはり改行の次の文は取れませんでした。

[ynakano]

ちょっと調べてみました。
Excelのセル内改行はvbLfらしいのですがいかがでしょうか。
外してたらごめんなさい。

[dokoniarukana]

vbLfでもダメみたいです。

[ynakano]

最初の"WorksheetFunction.Clean"で改行コードが失われていませんか？
"WorksheetFunction.Clean"直後に変数aの値を表示させてみたのですが、改行がなくなっていました。
※質問文のコードをそのままコピペしてもエラーが出てしまうので、少し修正してはいますが。

[dokoniarukana]

質問文コードが異なっていたので修正しました。

[ynakano]

変数bは配列宣言してないので「If Left(b(j), 1) = "『" Then」でエラーになります。
あと、"WorksheetFunction.Clean"実行直後の変数bの値を確認してみてください。

[dokoniarukana]

If Left(a(j), 1)　でしたね。
WorksheetFunction.Cleanの部分をコメントアウトして上記の流れを試してみましたが、
一向に取得できないですね。

[ynakano]

ちょっと脱線かもしれませんが、これ意味ありますか？

If Left(a(j), 1) = "『" Then
a(j) = Left(a(j), 1)
End If
a(j) = Left(a(j), 2)

a(j)はif文の結果にかかわらず【Left(a(j), 2)】になりませんか？

[dokoniarukana]

文頭が『であれば『○までは要らないのでそういう処理をしています。
『がきたらきちんと『のみを取るようになっていますよ。

"\r\n"でも改行とみなされないようです。。。

[ynakano]

五月雨式に済みません。
質問文には「空白でも区切りたい」とありますが、冒頭の

b = Replace(b, c, "")

で空白を削除していませんか？

[dokoniarukana]

そこは問題ないと思います。

[ynakano]

dokoniarukanaさんのやりたいと思われることが実現できた気がするのですが…
試してみていただければと思います。

Public Sub 抽出2()
Dim a() As String, b As String
Dim v As Variant
Dim i As Long, j As Long
Const c As String = " "

'D2から最終行まで探す
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
'Dのテキストを格納する
b = Cells(i, "D").Text
b = Replace(b, c, "")

'記号の次
For Each v In Array("。", vbLf)
b = Replace(b, v, c, , , vbTextCompare)
Next

a = Split(WorksheetFunction.Trim(b), c)

'0行目から最終行まで
For j = 0 To UBound(a)
'もし文頭が記号から始まれば1文字のみ取る
If Left(a(j), 1) = "『" Then
a(j) = Left(a(j), 1)
End If

a(j) = Left(a(j), 2)

' E列から左に貼り付け
Cells(i, j + 5).Value = a(j)
Next
Next
End Sub

[dokoniarukana]

やはりb = Cells(i, "D").Textの部分が原因だったんですね。
長々と付き合わせてしまって申し訳有りませんでした。
もう少し知識をつけてから質問しようと思います。
ありがとうございました。

[ynakano]

あとは末尾の「Cells(i, "E").Resize(, j).Value = b」もちょっと意図をつかみかねる記述でした。

[dokoniarukana]

そこも本当は　= a でした。
変数がごちゃごちゃになっていて全く意味不明なソースでした。
お手数お掛けしました。