指定した文字を検索

質問

エクセル2003を使っています。
ＶＢＡを使って文字を検索したいと思います。

(1)「あるセル」から見て最も近い、Ａ列の「ある特定の文字が入っているセル」を検索しコピーし、別シートに貼り付ける。
（最初の「あるセル」というのはデータによって、セルの場所が変わります。但し、Ａ列には入りません。
また、次の「特定の文字が入っているセル」というのは、データによってＡ列は変わりませんが、行番号は変わります。そして、特定の文字はＡ列に数個あります。そこであるセルから最も近いセルを検索するとします。）

例.
最初の「あるセル」をＪ３０とします。Ａ列に入っている「時間」という文字を探すことにします。但し、「時間」というのはＡ列に数個あります。
そこで、「Ｊ３０」から見て、最も近いセルの「時間」を検索してコピーし、別シートのセルＡ１に貼り付けます。

分かりにくいかもしれませんが、よろしくお願いします。

回答No.2

KenKen_SP · ベストアンサー

こんばんは。

Find メソッドの SearchDirection を xlNext, xlPrevious でそれぞれ
検索する方法でもできますよ。

Sub SampleProc()

　　Dim r1　　　 As Range
　　Dim r2　　　 As Range
　　Dim vKeyword As Variant
　　Dim n　　　　As Long

　　' // 検索文字の問い合わせ
　　vKeyword = Application.InputBox("ワイルドカードが使えます", _
　　　　　　　　　　　　　　　　　　Title:="検索キーワード", _
　　　　　　　　　　　　　　　　　　Type:=2)
　　If VarType(vKeyword) = vbBoolean Then
　　　　Exit Sub
　　End If

　　' // 前方と後方にそれぞれ検索
　　Set r1 = Columns("A").Find(What:=vKeyword, _
　　　　　　　　　　　　　　　 LookIn:=xlValues, _
　　　　　　　　　　　　　　　 LookAt:=xlWhole, _
　　　　　　　　　　　　　　　 SearchDirection:=xlNext)
　　Set r2 = Columns("A").Find(What:=vKeyword, _
　　　　　　　　　　　　　　　 SearchDirection:=xlPrevious)

　　' // アクティブセルより行番号が近い方をコピーする
　　If r1 Is Nothing And r2 Is Nothing Then
　　　　MsgBox "Not found.", vbInformation
　　Else
　　　　n = ActiveCell.Row
　　　　Set r1 = IIf(Abs(n - r1.Row) <= Abs(n - r2.Row), r1, r2)
　　　　r1.Copy Destination:=Worksheets("Sheet2").Range("A1")
　　End If

End Sub

> ＶＢＡを使って文字を検索したいと思います。
仕様の提示のみで、質問点が書かれていない気がしますが...

回答No.3

imogasi

（１）Findを用いる。
たまたま質問の内容から、ＦｉｎｄＮｅｘｔは不要でわかりやすいとおもう。下記方法では、第２の発見を求める必要が無い。
（２）この小生の思い付いたロジックの特徴は
中心（質問のＪ２０の場合はＡ列の第２０行。下記コードではｃ）から上下プラスマイナスi 行の範囲を検索し、見つからなければ、次は上下とも各１行を増やして検索する。これを順次、限度まで繰り返す。初めて見つかった行が、中心から一番近い検索語所在の行であるといえる（＜－ここがポイント）。限度はＡ列第１行と、データ最下行である。
ーーーーー
Sub test01()
Dim x As Range
Dim st As Integer
Dim ed As Integer
d = Range("A65536").End(xlUp).Row 'Ａ列データ最下行を求む
s = Range("B1") '探索語あるセル　例　時間
t = Range("C1") '中心セル　例Ｊ２０
c = Worksheets("Sheet1").Range(t).Row '中心セルの行番号を求む
'MsgBox c
For i = 1 To 20
'---Ａ列探索最上セル行番号ｓｔを求める
If c - i > 0 Then
st = c - i
Else
st = 1
End If
'---Ａ列探索範囲最下セル行番号ｅｄを求める
If d > c + i Then
ed = c + i
Else
ed = d
End If
'-----Ａ列探索範囲指定。st上限セル、edは下限セル行番号
Range(Cells(st, "A"), Cells(ed, "A")).Select
'--Ａ列行番号ｓｔ－ｅｄの範囲で検索語ｓを検索
Set x = Selection.Find(What:=s, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False)
If x Is Nothing Then '検索語見つからずー＞範囲を上下１行増やして検索
If st = 1 And ed = d Then '上限が第１行、下限がＡ列データ最下行に達しても
'検索語が見つからず
MsgBox "見つからず"
Exit Sub '処理終了
Else
GoTo p1 '範囲を上下１行広げて探索繰り返し
End If
Else
r = x.Row '見つかった行を求める
MsgBox r
Exit Sub '目的達成終了
End If
p1:
Next i
End Sub

回答No.1

hana-hana3

こんな感じでしょうか？
一番近い位置を同じ行として、一行上、一行下、二行上、二行下・・・と探していきます。

Sub test1()

Dim R As Long
Dim Ofs As Long
Dim i As Long
Dim Pos As Long
Dim word As String

R = ActiveCell.Row 'どこかのセル
word = InputBox("文字は？", "検索文字")

Pos = 0
If InStr(Cells(R, 1), word) > 0 Then
Pos = R
Else
For i = 1 To 65536
If R - i > 0 Then
If InStr(Cells(R - i, 1), word) > 0 Then
Pos = R - i
Exit For
End If
ElseIf R + i <= 65536 Then
If InStr(Cells(R + i, 1), word) > 0 Then
Pos = R + i
Exit For
End If
End If
Next
End If

If Pos <> 0 Then
Cells(Pos, 1).Copy Sheets("別シート").Range("A1")
End If

End Sub