Excelアルファベット文字列だけ一括抽出マクロ

質問

いつもお世話になっております。

Excel2013の
A列に、ひらがなカタカナ漢字、英数字、*"「などの記号（半角全角）などが入っている文字列があります。
そこからアルファベットの文字列だけ（数字は不要）を抽出して、結果をBCD・・・列に表示させたいのです（A1からの抽出結果はB1,C1…に表示、A2からの抽出結果はB2, C2…に表示）。

添付の画像ではA2までしか載せていませんが、
実際にはA列には1000くらいエントリーがあり、
それを一括でアルファベットの文字列を抽出したいのです。

ご存じの方、ご教示いただければ幸いですm(_ _)m

回答No.5

kagakusuki · ベストアンサー

全角文字半角文字、大文字、小文字の区別なく、A列の１行目以下のセルに入力されている文字列の中でアルファベットが連続している部分だけを抽出するマクロです。

Sub QNo8999911_Excelアルファベット文字列だけ一括抽出マクロ()

Dim c As Range, i As Long, j As Long, OrigiString As Variant, _
monoCharacter As String, myString As String, myColumn As String, _
CharacterCode As Long, FirstRow As Long, LastRow As Long

myColumn = "A" '元データである文字列が入力されている列
FirstRow = 1 '元データである文字列が入力されている最初の行
LastRow = Range(myColumn & Rows.Count).End(xlUp).Row
If LastRow < FirstRow Or Range(myColumn & LastRow).Value = "" Then
MsgBox "処理すべきデータが見つかりません", vbInformation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each c In Range(myColumn & FirstRow & ":" & myColumn & LastRow)
OrigiString = c.Value & " "
If OrigiString <> "" Then
j = 1
myString = ""
For i = 1 To Len(OrigiString)
monoCharacter = Mid(OrigiString, i, 1)
CharacterCode = Asc(StrConv(monoCharacter, vbLowerCase + vbNarrow))
If CharacterCode > 96 And CharacterCode < 123 Then
myString = myString & monoCharacter
ElseIf myString <> "" Then
c.Offset(, j).Value = myString
myString = ""
j = j + 1
End If
Next i
End If
Next c
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

お礼

完璧に動作しました！
求めていた動作ができました。ほんと助かりました！！！ありがとうございます。m(_ _)m

回答No.8

keithin

Ａ列にＡ１から元ネタが並んでいるとして。

sub macro1()
　dim h as range
　dim t as string
　dim a as variant

　for each h in range("A1:A" & range("A65536").end(xlup).row)
　　if h <> "" then
　　　t = h.value
　　　for c = 1 to len(t)
　　　　if not mid(t, c, 1) like "[a-zA-Z]" then
　　　　　mid(t,c,1) = " "
　　　　end if
　　　next c

　　　t = application.trim(t)
　　　if t <> "" then
　　　　a = split(t, " ")
　　　　h.offset(0, 1).resize(1, ubound(a)+1) = a
　　　end if
　　end if
　next
end sub

＃なんだか似たような回答が並びましたが，それぞれ実際に動作確認してご利用ください。

お礼

みなさんこんなことができるなんてうらやましいです。
ありがとうございましたm(_ _)m

回答No.7

山田 太郎（@f_a_007）

【お詫び】PulloutWords()は全面書き換えしました。

１、英単語以外が開始された時のみテキストを","に置換。
２、それ以外の非英単語はブランクに置換。
３、変換したテキストからブランクを除去。
４、先頭と末尾の","を除去。

で、どうやら無事に単語リストを生成するようです。

Public Function PulloutWords(ByVal strText As String) As String
　　Dim isNotWord　As Boolean
　　Dim I　　　　　As Integer
　　Dim L　　　　　As Integer
　　Dim S　　　　　As Integer
　　Dim E　　　　　As Integer
　　Dim strC　　　 As String
　　Dim strNewText As String

　　L = Len(strText)
　　For I = 1 To L
　　　　strC = Mid(strText, I, 1)
　　　　If Not (strC >= "A" And strC <= "z") Then
　　　　　　If isNotWord Then
　　　　　　　　Mid(strText, I, 1) = " "
　　　　　　Else
　　　　　　　　isNotWord = True
　　　　　　　　Mid(strText, I, 1) = ","
　　　　　　End If
　　　　Else
　　　　　　isNotWord = False
　　　　End If
　　Next
　　'
　　' 先頭と末尾の","を除去する
　　'
　　strNewText = Replace(strText, " ", "")
　　S = Abs(Left(strNewText, 1) = ",")
　　E = Abs(Right(strNewText, 1) = ",")
　　L = Len(strNewText)
　　PulloutWords = Mid(strNewText, 1 + S, L - S - E)
End Function

※テスト不足でした。

回答No.6

山田 太郎（@f_a_007）

【訂正】単語リストの先頭と末尾の処理をより厳密に！

Public Function PulloutWords(ByVal strText As String) As String
　　Dim I As Integer
　　Dim L As Integer
　　Dim S As Integer
　　Dim E As Integer
　　Dim strC　　As String
　　Dim strNewText As String

　　L = Len(strText)
　　For I = 1 To L
　　　　strC = Mid(strText, I, 1)
　　　　If Not (strC >= "A" And strC <= "z") Then
　　　　　　Mid(strText, I, 1) = ","
　　　　End If
　　Next
　　strNewText = Replace(Replace(strText, ",,", ","), ",,", ",")
　　'
　　' 先頭と末尾の","を除去する
　　'
　　S = Abs(Left(strNewText, 1) = ",")
　　E = Abs(Right(strNewText, 1) = ",")
　　L = Len(strNewText)
　　PulloutWords = Mid(strNewText, 1 + S, L - S - E)
End Function

お礼

時間をとっていただきありがとうございました。
長い年月をかけて身に付けた技術でたすけていただき感動です。

回答No.4

Chiquilin

ユーザー定義関数を作りますか。

Function POW(r As Variant, n As Long) As String
Dim pArry As Variant
Dim pStr As String, midi As String
Dim i As Long
For i = 1 To Len(r.Value)
midi = Mid$(r.Value, i, 1)
pStr = pStr & IIf(midi Like "[a-zA-Z]", midi, " ")
Next i
pArry = Split(WorksheetFunction.Trim(pStr), " ")
If UBound(pArry) + 1 < n Then Exit Function
POW = pArry(n - 1)
End Function

B1セルに「=POW($A1,COUMN(A1))」と入れて 右にコピー

回答No.3

mt2008

例を見る限り半角のアルファベットだけを取り出したいようなのでこんな感じでいいかな？
Sub Sample()
　　nLast = Cells(Rows.Count, 1).End(xlUp).Row
　　For nRow = 1 To nLast
　　　　sStr = Cells(nRow, 1).Text
　　　　sWork = ""
　　　　For i = 1 To Len(sStr)
　　　　　　sOne = Mid(sStr, i, 1)
　　　　　　If (Asc(sOne) >= Asc("A")) And (Asc(sOne) <= Asc("z")) Then
　　　　　　　　sWork = sWork & sOne
　　　　　　Else
　　　　　　　　sWork = sWork & " "
　　　　　　End If
　　　　Next i
　　　　Cells(nRow, 2) = Trim(sWork)
　　Next nRow
　　Columns("B:B").TextToColumns DataType:=xlDelimited, Space:=True, TrailingMinusNumbers:=True
End Sub

お礼

全角半角混合でした。ありがとうございました。

回答No.2

山田 太郎（@f_a_007）

添付図のように２つの関数を用意します。

【２つの関数】

１、単語を抜き出す PulloutWords()。
２、単語リストから指定番目を抜き出す CutStr()。

【関数の利用方法】

１、１で抜き出した単語をダミー列に非表示で格納。
２、ダミー列の単語リストを順次抽出し表示。

【関数のアイデア】

１、PulloutWords()は、指定テキストのアルファベット以外を","に置換する。
２、Replace()で単語リストを"ABC,ABC,ABC"のフォームに整形。
３、CutStr()では　Split()　で抜き出す。

Public Function PulloutWords(ByVal strText As String) As String
　　Dim I As Integer
　　Dim L As Integer
　　Dim strC　　As String

　　L = Len(strText)
　　For I = 1 To L
　　　　strC = Mid(strText, I, 1)
　　　　If Not (strC >= "A" And strC <= "z") Then
　　　　　　Mid(strText, I, 1) = ","
　　　　End If
　　Next
　　PulloutWords = Replace("," & Replace(Replace(strText, ",,", ","), ",,", ",") & ",", ",,", "")
End Function

Public Function CutStr(ByVal Text As String, _
　　　　　　　　　　　　ByVal Separator As String, _
　　　　　　　　　　　　ByVal N As Integer) As String
　　Dim strDatas() As String

　　strDatas = Split("" & Separator & Text, Separator, , 0)
　　CutStr = strDatas(N * Abs(N <= UBound(strDatas)))
End Function

お礼

お忙しいところありがとうございましたm(_ _)m
こんなコードが書けるなんて尊敬します。

回答No.1

misatoanna

データ範囲のセル(A1:Axx)を選択した状態で実行します。

Sub Test()
　Dim rng As Range, DT As String, splt As Variant
　Dim i As Long, k As Long
　For Each rng In Selection
　　For i = 1 To Len(rng.Value)
　　　If Mid(rng.Value, i, 1) Like "[A-Z]" Or _
　　　　　Mid(rng.Value, i, 1) Like "[a-z]" Then
　　　　DT = DT & Mid(rng.Value, i, 1)
　　　Else
　　　　DT = DT & " "
　　　End If
　　Next
　　DT = WorksheetFunction.Trim(DT)
　　splt = Split(DT, " ")
　　For k = 0 To UBound(splt)
　　　rng.Offset(0, k + 1).Value = splt(k)
　　Next
　　DT = ""
　Next
End Sub

お礼

お時間を取っていただいて書いてくださってありがとうございましたm(_ _)m