Excelから特定の文字のみ抜き出したい。

Question

前提・実現したいこと

ExcelのデータA列にある各セルから名前だけ抜き出したいのです。
1個のセル各々には1人、複数人の名前とコメントが書いてあります。
下説明にあります(1)⇒(2)のようにしたいのです。

【追記】アドバイスをいただき追記いたしました。ありがとうございます。
改行を追記しました。「○○さん」はコメントの中にも存在しますが、コメントの中にある〇〇さんの後には改行はありません。

(1)＜Excelにあるデータ＞
A1セル：○○さん\改行　本日はテスト
A2セル：BBさん\改行vvさん\改行ccさん\改行　本日はBBさんありがとうございました。
A3セル：ddさん\改行FFさん\改行HHさん\改行GGさん\改行　テストテストテスト
・
・
・
・
・
A1000セル：zzさん\改行ccさん\改行HHさん\改行　晴れです。よろしくお願いいたします。

(2)＜やりたいこと＞
B1セル：○○さん\改行
B2セル：BBさん\改行vvさん\改行ccさん\改行
B3セル：ddさん\改行FFさん\改行HHさん\改行GGさん\改行
・
・
・
・
・
B1000セル：zzさん\改行ccさん\改行HHさん\改行

発生している問題・エラーメッセージ

コンパイルエラー　修正候補　ステートメントの最後と表示されました。
※ActiveCell.FormulaR1C1の行で発生しました。

該当のソースコード

Sub Do_While_Loop_Sam()

    Dim i As Long
    i = 1
    Do While Cells(i,1)
       Cells(i,1)=Cells(i,1)+1
       i=i+1
       Range(B1:B1000).Select
       ActiveCell.FormulaR1C1 = "=LEFT(A1:A1000,FIND("さん",A1:A1000)+1"
   
    Loop
    End Sub

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[radames1000]

・コメントの中に「さん」という文字が含まれることはありませんか？（「みなさん」とか）
・VBA使用可能なら、タグに「VBA」を含めると回答が集まりやすいかもしれません。

[Kirari]

ありがとうございます。VBAを追加しました。
コメントの中にも、確かに「さん」が含まれる可能性があります。
⇒例えばですが、「〇〇さん　本日はありがとうございました。○○さんのご協力で……」の場合があります。この場合はLEFTやLENの関数を使っていくと良いのでしょうか？

[radames1000]

ルールが明確であればいろいろ方法はあるかと思います。
最初の「〇〇さん　△△さん　」といった部分ですが、
これは名前の後に必ずスペースがあるのでしょうか？（あるとしたら半角？全角？）
そして、コメントの中で「さん」が使われるとき、そのあとにスペースは入りませんか？

[Kirari]

ありがとうございます。〇〇さん　△△さん　××さん　のそれぞれの空欄には
「○○さん\n△△さん\n××さん\n」の改行が入ります。
コメントの中にある「〇〇さん」のあとには改行はありません。

[radames1000]

「改行」であることは質問本文からは読み取れませんので、ぜひ本文を修正なさってください。
コードも変わってくると思います。

[Kirari]

ありがとうございます。

Answer 1

Sub TEST()
    With ActiveSheet.Range("B:B")
        .Offset(, -1).Copy .Cells
        .Replace "　*", ""
    End With
End Sub

これでいいのかな？

やってることは列ごとコピペして、
全角スペース以降の文字列を長さ0の文字列に置き換えしてるだけ。
プログラミングを勉強するのもいいけど、エクセルの使い方を勉強してみては？
コードを書いている間にかたづく仕事です。
数式や機能を覚えた方が後で応用が利くかと思いました。

手動で数式でやるなら一番上の1個のセルに数式を入れて、フィルハンドルダブルクリックで、
十分かと。
それから、数式は一括で複数セルに入れることが可能なので、
ループの必要はないです。事前に入力したいセル範囲を取得必要はありますが。

あと、
複数セルを選択しても、
アクティブなセルは1つだけです。

Comments

[Kirari]

ありがとうございます。やってみます。

Answer 2

「さん」と改行の組み合わせを後ろから検索してみました。

Sub CleanupString()
    Dim r As Range
    For Each r In Range("A1").CurrentRegion
        r.Offset(, 1).Value = Left(r.Value, InStrRev(r.Value, "さん" & Chr(10)) + 2)
    Next
End Sub

Comments

[Kirari]

返信が遅くなりまして申し訳ございません。ご回答ありがとうございます。上記を入れて実行すると、データがすべて「20」という数字に書き換わってしまいます（A列、B列、C列、D列……）。B列以降に影響を及ぼさないように、列を変更した方がいいのでしょうか。何回か試してみようと思います。

Answer 3

編集後の質問だと、単純に「全角空白」より前を取り出せばいいことになりますね。

Sub Sample()
    Dim c As Range
    For Each c In Range("A1").CurrentRegion
        c.Offset(, 1).Value = Split(c.Value, "　")(0)
    Next
End Sub

Comments

[Kirari]

返信が遅くなりまして申し訳ございません。ご回答ありがとうございます。上記を入れて実行しますと、B列以降がA列と同じ内容に書き換わってしまいます。列を変更した方がいいのでしょうか。何回か試してみようと思います。

Answer 4

こんにちは。よろしくおねがいいたします。
これは、いろいろな方法があると思いますが、とりあえず僕が思いついたのは以下のようなものです。

今、こういうシートがあって、これを”クリーンアップ”したいとき。

こういうコードはどうでしょう？

Option Explicit

Sub CleanupString()
'文字列から”さん"がついた人名の部分だけ取り出すプログラムです

'A列に「BBさん　vvさん　ccさん　本日はありがとうございました」といった文字列があるとき、
'B列に「BBさん vvさん ccさん 」を出力する

Dim InputStringSet As String
Dim CleanedString As String

Dim ArrName As Variant
Dim i As Long
Dim r As Range

'A列を、データがなくなる行まで　上から下までナメていきます
For Each r In Range("A1", Range("A1").End(xlDown))

  'Anセルの文字列を得ます
  InputStringSet = r.Value

  '念のため、全角スペースを半角スペースに置換しておきます
  InputStringSet = Replace(InputStringSet, "　", " ")

  '"さん[半角スペース] "を、カンマに置換します
  InputStringSet = Replace(InputStringSet, "さん ", ",")

  'カンマで区切った単位で、いったん配列に格納します
  ArrName = Split(InputStringSet, ",")

  '配列に格納した名前を、順番に　”さん "をつけなおして つなぎなおします
  '配列の最後のデータは’名前’ではない、という前提です
  For i = 0 To UBound(ArrName) - 1
    CleanedString = CleanedString & ArrName(i) & "さん "
  Next i

  '結果をB列に出力する
  r.Offset(0, 1).Value = CleanedString

  '次のループに備えてCleanedStringを初期化する
  CleanedString = ""

Next r

End Sub

この結果は、こんなカンジです。

”さん　”という文字列をいったんカンマに置き換えて、CSVみたいにみたてて、
それをSplitで刻んで、Arrayに入れて、
再度そのArrayを順番に得て、もいちど”さん "に戻す、というようなことをやってみました。

文字列の検索置換は、ほんとうにいろいろな解決法があります。
これはあくまで一例ですが、参考になれば...

Comments

[radames1000]

置換せずにいきなり配列に入れる方法もありますね。
ArrName = Split(InputStringSet, "さん ")

[ttyp03]

最後の文字列化するところはReDimで1要素減らしたあとJoinが楽かと。
For Each r In Range("A1", Range("A1").End(xlDown))
ArrName = Split(r, " ")
ReDim Preserve ArrName(UBound(ArrName)-1)
r.Offset(0, 1).Value = Join(ArrName, " ")
Next

[Kirari]

返信が遅くなりまして申し訳ございません。ご回答ありがとうございます。上記を入れて実行しますと、B列以降のデータが消えてしまいます。何回か試してみようと思います。

Answer 5

試してみてください

Sub tes()

    For r = 1 To 1000
       'Cells(r, 2).Formula = "=LEFT(A" & r & ",FIND(""さん"",A" & r & ")+1)"
       Cells(r, 2).Formula = "=LEFT(R[]C[-1],FIND(""さん"",R[]C[-1] )+1)"
    Next

End Sub
       

追記
"さん"の後に改行あると一人目しか拾えませんね

Comments

[Kirari]

ご連絡遅くなりまして申し訳ございません。ご返信ありがとうございます。実行してみましたが、列のデータが変わりませんでした。何回か試してみようと思います。