Excel VBA 半角英数の抽出もしくは全角文字の削除

質問

Excel2003でVBAを使って、次の２点のことを行いたいと思っております。

１）全角・半角文字が混在している大量のデータから半角英数記号だけを取り出す。

過去のQ&A（http://oshiete1.goo.ne.jp/qa3158346.htmlのNo.3）から類似した回答を見つけましたが、この方法ですと「=AtoZ(A1)」とセルを指定しなければいけません。一度に半角英数記号を取り出す方法はございませんか？

２）抽出するデータは英文で１つのセルに複数の文章が入力されているのですが、文章を区切って１つのセルには１文のみの入力にする。

例えば、下記の文章がA3にあるとします。
Spring came. Freddie, the leaf, was born on a branch of a tall tree. Hundreds of leaves were born on the tree. They were all friends.
これを
A3にはSpring came.
A4にはFreddie, the leaf, was born on a branch of a tall tree.
A5にはHundreds of leaves were born on the tree.
A6にはThey were all friends.
と入力したいのですが、方法はございませんか？

膨大なデータを扱うため、大変困っています。どなたかご教授お願いします。

回答No.4

hyakusaizi

1については、引数をループで回せばよいのかな、と直感的に思います.検証できていませんが

2については、
Splitを使ったら簡単にかけるのではないでしょうか?

前提としては各文の終わりにちゃんとピリオドが書いてあることですね

Dim Sentence() As String
Dim Row as Long
Dim Counter as Long
Row = 3

Sentence =　Split(Cells(3,1).Value, ".")'A3セルの中身を.で切って配列に格納
For Counter =　0 To UBound(Sentence)
Cells(Counter +　3, 1).value =　Sentence(Counter) &　"."
Next Counter

と言う感じでしょうか
動作確認をしていませんが・・・

回答になっているでしょうか？

回答No.3

noname#79209

#2さんが言われるように、エクセルの仕事ではありません。

私なら。まず正規表現が扱えるテキスト・エディタを入手します。
フリーソフトでも良いかも知れませんが、有料ですが以下のソフトがあります。
http://www.villagecenter.co.jp/soft/wz50/
http://www.rimarts.co.jp/dana-j.htm
http://hide.maruo.co.jp/software/hidemaru.html

「メモ帳」では正規表現が使えませんし、膨大なデータなら、「メモ帳」では扱えない大きさでしょう。

エクセルからテキスト・ファイルとして保存すれば、テキスト・テディタで読み込むことができます。

また、
> 全角・半角文字が混在している大量のデータから半角英数記号だけを取り出す。
と言われていますが、「取り出す」とは単なる「検索」なのか「置き換え」なのか、
「取り出して」その後どうしたいのかを書かないと、的確な回答は得られないと思います。

回答No.2

Wendy02

こんばんは。

両方とも、Excel向きではありませんね。
特に、膨大なデータならなおさらだと思います。
本来、テキストファイルの中で処理したほうが早いです。

もしかしたら、私と同業者？（私の場合は、もう少し複雑なんです）なのかもしれませんが、特に、2番目のセンテンス切り分けですが、正しく、最初大文字でセンテンスの最後が「.（ピリオド）」で終わっているならよいのですが、実際は、そういうことにならないことが多いのです。それで、結局、後から、手動で入れていくことが多いですね。
ただ、正規表現のマニュアルを手に入れて、後は、ご自身でやってみてください。他人にいちいち聞いているよりも、そのほうが早いです。練習は、エディタ上でしてください。後戻りが利きます。文系・理系を問わず、テキスト処理する人は、正規表現は必須です。

'標準モジュールに貼り付けてください。
'-----------------------------------------------
'半角英数抽出
'-----------------------------------------------
Sub TestRegExp1()
　　Dim Buf2 As Variant
　　Dim dummy As Variant
　　Dim myData As String
　　Dim c As Variant
　　Dim i As Long
　　i = 1
　　For Each c In Range("A1:A10")　'検索範囲
　　　If VarType(c) = vbString Then
　　　　Buf2 = OneByteChar(c.Value)
　　　　On Error Resume Next
　　　　dummy = UBound(Buf2)
　　　　On Error GoTo 0
　　　　If IsNumeric(dummy) Then
　　　　'コピー先
　　　　　Worksheets("Sheet2").Cells(i, 2).Resize(UBound(Buf2) + 1).Value _
　　　　　　　 = WorksheetFunction.Transpose(Buf2)
　　　　　 i = i + 1 + UBound(Buf2)
　　　　End If
　　　　Buf2 = ""
　　　　dummy = ""
　　　End If
　　Next c

End Sub
Function OneByteChar(ByVal strText As String)
'正規表現抽出
　Dim Buf() As String
　Dim myPat As String
　Dim Matches As Object
　Dim Match As Object
　Dim i As Long

　myPat = "[\dA-z]+"

　　With CreateObject("VBScript.RegExp")
　　　　.Global = True
　　　　.IgnoreCase = False
　　　　.Pattern = myPat
　　　　Set Matches = .Execute(strText)
　　　　For Each Match In Matches
　　　　　　ReDim Preserve Buf(i)
　　　　　　Buf(i) = Match
　　　　　　i = i + 1
　　　　Next Match
　　End With
　　OneByteChar = Buf()
End Function

'-----------------------------------------
'センテンス抽出
'-----------------------------------------
Sub TestRegExp2()
　　Dim Buf() As String
　　Dim myData As String
　　Dim myPat As String
　　Dim Matches As Object
　　Dim Match As Object
　　Dim i As Long

　　'元のデータ
　　myData = Range("A3").Value

　　myPat = "([A-Z][^\.]+\.)"

　　If myData = "" Then MsgBox "データがありません", 48: Exit Sub
　　With CreateObject("VBScript.RegExp")
　　　　.Global = True
　　　　.IgnoreCase = False
　　　　.Pattern = myPat
　　　　Set Matches = .Execute(myData)
　　　　For Each Match In Matches
　　　　　　ReDim Preserve Buf(i)
　　　　　　Buf(i) = Match
　　　　　　i = i + 1
　　　　Next Match
　　End With
　　Range("A3").Resize(UBound(Buf()) + 1).Value = WorksheetFunction.Transpose(Buf())
End Sub

回答No.1

noname#176215

やろうとしていることと 条件が合わないように見えるんですが……

=TRIM(MID(SUBSTITUTE(A$3,".","."&REPT(" ",255)),(ROW(A1)-1)*256+1,255))

これでいいなら。