文字列からアルファベットを抽出（２）

質問

以下、文字列から英字を抜き出すサンプルを頂戴しました。

Sub test()
Dim i, k As Long
Dim str, buf As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 3) = WorksheetFunction.Substitute _
(WorksheetFunction.Substitute(Cells(i, 1), "]", ""), "[", "")
For k = 1 To Len(Cells(i, 3))
str = Mid(Cells(i, 3), k, 1)
If str Like "[A-z,Ａ-ｚ]" Then
buf = buf & str
End If
If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ, ]" Then Exit For
Next k
Cells(i, 2) = buf
buf = ""
Next i
Columns(3).ClearContents
End Sub

上記に以下の2つの機能を付け足したいです。

2文字以下の英字の時は英字がなかったものとして空白をかえしてほしい。→（1）
（例）身長が3cm伸びた田中君→空白
（例）身長が3cm伸びたXYZ君→XYZ
（例）こちらABC放送局→ABC

最初の一塊と後から出てくる一塊の長いほうをかえしてほしい。→（2）
（例）学期末TESTの成績はAAAです→TEST（前が長い）
（例）学期末TESTの成績はABCDです→TEST（同じ長さ）
（例）学期末TESTの成績はABCDEです→ABCDE（後が長い）

(1)と(2)を状況に応じて機能させたり停止したりしたいので
その部分のソースを明示して頂けましたら幸いです。
厚かましいお願いですが、何卒よろしくお願いいたします。

回答No.4

tom04 · ベストアンサー

No.3です！
続けてお邪魔します。

今回は（2）の方のコードになります。
今回もアルファベットの塊は二つとしています。

Sub test2()
Dim i, k As Long
Dim str, buf As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 3) = WorksheetFunction.Substitute(WorksheetFunction.Substitute _
(WorksheetFunction.Substitute(Cells(i, 1), " ", ""), "]", ""), "[", "")
For k = 1 To Len(Cells(i, 3))
str = Mid(Cells(i, 3), k, 1)
If str Like "[A-z,Ａ-ｚ]" Then
buf = buf & str
End If
If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ]" Then Exit For
Next k
Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = buf
buf = ""
Next i
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 3) = WorksheetFunction.Substitute(Cells(i, 3), Cells(i, 4), "")
For k = 1 To Len(Cells(i, 3))
str = Mid(Cells(i, 3), k, 1)
If str Like "[A-z,Ａ-ｚ]" Then
buf = buf & str
End If
If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ]" Then Exit For
Next k
Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = buf
buf = ""
If Len(Cells(i, 4)) >= Len(Cells(i, 5)) Then
Cells(i, 2) = Cells(i, 4)
Else
Cells(i, 2) = Cells(i, 5)
End If
Next i
Range("C:E").Delete
End Sub

以上、かなり強引なコードですが他に良い方法があればごめんなさいね。m(__)m

お礼

再三のご回答ありがとうございます。今後は自分でもこのようなVBが扱えるように時間を作って精進したいと思います。ご教示頂いたソースで作業が楽になり空いた時間に勉強したいと思いますので今後また困った時は宜しくお願い致します。
今回はまた遠方に戻る為に簡単なテストしか出来ませんでした。思った動作をしてくれませんでしたが、帰ってきたら試行錯誤しながら改造させて頂きたいと思います。ありがとうございました。

回答No.3

tom04

こんばんは！
前回投稿した者です。
乗りかかった船ですので、何とかご希望に添えれば良いのですが・・・

無理矢理って感じの方法です。
アルファベットの塊は二つだけとしています。
まず、（1）の場合の場合のコードです。

Sub test1()
Dim i, k As Long
Dim str, buf As String
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 3) = WorksheetFunction.Substitute(WorksheetFunction.Substitute _
(WorksheetFunction.Substitute(Cells(i, 1), " ", ""), "]", ""), "[", "")
For k = 1 To Len(Cells(i, 3))
str = Mid(Cells(i, 3), k, 1)
If str Like "[A-z,Ａ-ｚ]" Then
buf = buf & str
End If
If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ]" Then Exit For
Next k
Cells(i, 2) = buf
buf = ""
Next i
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Len(Cells(i, 2)) < 3 Then
Cells(i, 3) = WorksheetFunction.Substitute(Cells(i, 3), Cells(i, 2), "")
Cells(i, 2) = ""
For k = 1 To Len(Cells(i, 3))
str = Mid(Cells(i, 3), k, 1)
If str Like "[A-z,Ａ-ｚ]" Then
buf = buf & str
End If
If Len(buf) > 0 And Not str Like "[A-z,Ａ-ｚ]" Then Exit For
Next k
End If
Cells(i, 4) = buf
If Cells(i, 4) <> "" Then
Cells(i, 2) = Cells(i, 4)
End If
buf = ""
Next i
Range("C:D").Delete
End Sub

尚、（2）の場合のコードを載せると2000文字を超えそうなので
もう一度続けて投稿します。

まずはここまで・・・m(__)m

回答No.2

mu2011

先ずは、頂かれたサンプルコードを理解する事が必要ではないでしょうか。
理解すれば（１）については直ぐに解が得られると思う、（２）についてソースの明示は
丸写しされるとご質問者の為になりませんからヒントを回答します。

>2文字以下の英字の時は英字がなかったものとして空白をかえしてほしい。
　⇒「If Len(buf) > 0　～」を変更、但し、英字単語が１つの場合のみに限る

>最初の一塊と後から出てくる一塊の長いほうをかえしてほしい。
　⇒文字列の組立用と設定用の２つ分のエリアを持ち、組立用文字数が設定用文字数より
　　大の場合に組立用から設定用にコピーする様にする
　　この場合、前述の条件も併せた判定をすれば一石2鳥である事は言うまでもない

お礼

一身上の都合で遠方に月曜の晩から行っており、昨日戻って参りました。ご回答を頂戴致しましたのに長らくお返事できずに申し訳ございませんでした。

まったく仰る通りです。自分で勉強して書けるようになりたいですが、今回は頂戴したソースを使わせて頂きました。以後、時間が有る時には勉強して行きたいと思います。ありがとうございました。

回答No.1

某HN クロメート(Chromate)（@CoalTar）

(1)も(2)も質問のプログラムを解析し、アルファベットの塊が2つだったら簡単にできそう。

B1セルが出る
A1セルの文字列からB1セルの文字を置き換え、C1セルに代入する
C1セルからアルファベットを取り出す
文字の長さを比較してどちらかを採用する

最終結果が2文字以下なら消す
付加すれば(1)になる

お礼

一身上の都合で遠方に月曜の晩から行っており、昨日戻って参りました。ご回答を頂戴致しましたのに長らくお返事できずに申し訳ございませんでした。

ご説明して頂いた理屈は理解致しましたが脳が実際のコードを書く技量がございませんでした。今後は自分でもっと考えれるように勉強したいと思います。ありがとうございました。