エクセルのデータ処理

質問

A列に単語が100ほどあります。
この中から特定の字（aとか bを含む単語をB列に選びだし、C列にその字の前からの位置を出したいのです。２字の場合は先頭でよい。

VBAで組むことはできますか、教えてください。
よろしくお願いします。

Ａ　　　　 B C
aを含む語 前からの位置
dog　　　　cat　　　　　　２
cat 　　　　 map　　　　　　２
desk 　　　　 table　　　　　２
map 　　　　 miracle　　　　４
table 　　　　 weather　　　　３
miracle 　　　　 calendar　　　 ２ （２と７）
weather
cloth
calendar

回答No.6

n-jun · ベストアンサー

Ａ列の単語でa～zをそれぞれ含んでいるものをＢ列以降に、
順次抽出と開始位置を書き出す。
Ｂ列以降の１行目に検索した文字を書き出す。

Sub　test2()
　Dim　re　As　Object
　Dim　Matches　As　Object
　Dim　i　As　Long,　j　As　Long,　k　As　Integer
　Dim　R_max　As　Long,　st　As　String
　Dim　v,　x

　With　ActiveSheet
　　　　　　v　=　.Range(.[A2],　.Cells(Rows.Count,　1).End(xlUp)).Value
　　　　　　ReDim　x(1　To　52,　1　To　UBound(v,　1))
　　　　　　Set　re　=　CreateObject("VBScript.RegExp")

　　　　　　For　k　=　1　To　26
　　　　　　　　　　st　=　Chr(k　+　96)
　　　　　　　　　　.Range("B1").Offset(,　(k　-　1)　*　2).Value　=　st
　　　　　　　　　　re.Pattern　=　"["　&　st　&　"]"

　　　　　　　　　　For　i　=　1　To　UBound(v,　1)
　　　　　　　　　　　　　　If　re.test(v(i,　1))　Then
　　　　　　　　　　　　　　　　　Set　Matches　=　re.Execute(v(i,　1))
　　　　　　　　　　　　　　　　　j　=　j　+　1
　　　　　　　　　　　　　　　　　x(k　*　2　-　1,　j)　=　v(i,　1)
　　　　　　　　　　　　　　　　　x(k　*　2,　j)　=　Matches.Item(0).FirstIndex　+　1
　　　　　　　　　　　　　　End　If
　　　　　　　　　　Next
　　　　　　　　　　If　R_max　<　j　Then　R_max　=　j
　　　　　　　　　　j　=　0
　　　　　　Next
　　　　　　ReDim　Preserve　x(1　To　52,　1　To　R_max)
　　　　　　.Range("B2").Resize(R_max,　52).Value　=　Application.Transpose(x)
　End　With
　Erase　v,　x
　Set　re　=　Nothing
　Set　Matches　=　Nothing
End　Sub
こうゆう事ですか？

お礼

わぁ～、一発で見事に並びました。プログラムというのはすごいですね。
度々お手数をおかけして申し訳ありませんでした。
ありがとうございました。

回答No.5

n-jun

ANo.2です。

>欲張って横の列に b から z までを抽出することもできますでしょうか。
それはANo.3さんが提示されている表のように、１行目に検索文字があり
抽出された文字と文字位置をＢ列から右に順次表示したいと
言う事ですか？

具体的な例題（レイアウト：表）を提示して頂けますか？

回答No.4

imogasi

例データ
A列
dog
cat
desk
map
table
miracle
weather
cloth
calendar
catakata
ーーー
VBAコード
標準モジュールに
Sub test01()
d = Range("A65536").End(xlUp).Row
k = 1 '第２行から書き出す準備
For i = 1 To d
s = 1 '最初の文字から検索準備
p = 1 'とりあえずpを０以外にセット
j = 2 '文字位置はB列からセット開始準備
fst = "Y" '最初の文字探索場面のフラグ
Do
p = InStr(s, Cells(i, "A"), "a")
If p = 0 Then Exit Do
If fst = "Y" Then
k = k + 1 '最初は１行下をポイントし書き込み準備
Cells(k, j) = Cells(i, "A") '単語をセット
End If
Cells(k, j + 1) = p '文字の位置セット
s = p + 1 '見つかった次の文字から探索準備
j = j + 1 '次列にセット準備
fst = "N"
Loop
Next i
End Sub
短いけれどロジック（コントロール）はややこしいと思うかも。

お礼

回答ありがとうございました。
みなさんのお力でうまく解決できました。
ありがとうございました。

回答No.3

q-0-p

'*********************************
Sub test()
　Dim ws1 As Worksheet
　Dim row1, row2 As Integer
　Dim kye As String

　　Set ws1 = Sheets("sheet1")

　　row1 = 2
　　row2 = 2
　　kye = ws1.Cells(1, 1)
　　Do Until IsEmpty(ws1.Cells(row1, 1))
　　　If ws1.Cells(row1, 1) Like "*" & kye & "*" Then
　　　　ws1.Cells(row2, 2) = ws1.Cells(row1, 1)
　　　　ws1.Cells(row2, 3)=Application.WorksheetFunction.
　　　　　　　　　　　　　　Find(kye, ws1.Cells(row2, 2))
　　　　row2 = row2 + 1
　　　End If
　　　row1 = row1 + 1
　　Loop
End Sub
'******************************************
　　A　　　　　B　　　　　　C
1　a
2　dog　　　　cat　　　　　2
3　cat　　　　map　　　　　2
4　desk　　　table　　　　 2
5　map　　　　miracle　　　4
6　table　　　weather　　　3
7　miracle　　calendar　　 2
8　weather
9　cloth
9 calendar

これでいかがでしょうか？

お礼

回答ありがとうございました。
みなさんのお力でうまく解決できました。
ありがとうございました。

回答No.2

n-jun

変数STにセットした文字にて処理を実行する。
１行目は項目行と判断したので、データ処理は２行目以降で
行なってます。

Sub　test()
　Dim　re　As　Object
　Dim　Matches　As　Object
　Dim　i　As　Long,　j　As　Long,　st　As　String
　Dim　v,　x

　With　ActiveSheet
　　　　　　v　=　.Range(.[A2],　.Cells(Rows.Count,　1).End(xlUp)).Value
　　　　　　ReDim　x(1　To　2,　1　To　UBound(v,　1))
　　　　　　Set　re　=　CreateObject("VBScript.RegExp")

　　　　　　'探したい文字を変数STに代入
　　　　　　st　=　"a"
　　　　　　re.Pattern　=　"["　&　st　&　"]"

　　　　　　For　i　=　1　To　UBound(v,　1)
　　　　　　　　　　If　re.test(v(i,　1))　Then
　　　　　　　　　　　　　Set　Matches　=　re.Execute(v(i,　1))
　　　　　　　　　　　　　j　=　j　+　1
　　　　　　　　　　　　　x(1,　j)　=　v(i,　1)
　　　　　　　　　　　　　x(2,　j)　=　Matches.Item(0).FirstIndex　+　1
　　　　　　　　　　End　If
　　　　　　Next
　　　　　　ReDim　Preserve　x(1　To　2,　1　To　j)
　　　　　　.Range("B2").Resize(j,　2).Value　=　Application.Transpose(x)
　End　With
　Erase　v,　x
　Set　re　=　Nothing
　Set　Matches　=　Nothing
End　Sub

補足

早速にご回答いただきありがとうございました。
一瞬で見事に現れたので感動しました。
欲張って横の列に b から z までを抽出することもできますでしょうか。
よろしくお願いします。

回答No.1

maron--5

◆VBAではなく、関数ですが（作業列による方法です）
　　　A　　　　B　　　　　　　　C　　　　　　　　D　　　　　E
1　　　　　aを含む語　　前からの位置
2　　dog　　　cat　　　　　　　　2
3　　cat　　　map　　　　　　　　2　　　　　　　　　　　　　3
4　　desk　　 table　　　　　　　2
5　　map　　　miracle　　　　　4　　　　　　　　　　　　　5
6　　table　　weather　　　　　3　　　　　　　　　　　　　6
7　　miracle　calendar　　 　　2　　　　　　　　　　　　　7
8　　weather　　　　　　　　　　　　　　　　　　　　　　　　8
9　　cloth
10　 calendar　　　　　　　　　　　　　　　　　　　　　　　10

E2=IF(COUNTIF(A2,"*a*"),ROW(),"")
★下にコピー

B2=IF(ROW(A1)>COUNT(E:E),"",INDEX(A:A,SMALL(E:E,ROW(A1))))
★下にコピー

C2=IF(B2="","",FIND("a",B2))
★下にコピー

お礼

関数でできるとは思いませんでした。
うまくできるものですね。
ありがとうございました。