人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

お気持ちのみですが全部で150p差し上げます。エクセルVBAについて質問です。

選択している範囲(selection)の中から、検索単語searchKeyを含む文字列を値として持つを持つセル最大100個を返す

Function GetRange(searchKey as String, MaxNum as Long) as Range (100)
End Function

を作って下さい。

・但し、検索単語searchKeyは大文字・小文字や全角・半角の区別がありません。
・また文字列全部が一致するのではなく、文字列中に一致する文字列があればOKとします。
例えば
adfafDF'daf
という値を持つセルは、searchKey
FdF’D
にヒットします。

さらに、MaxNumは、検索に一致したセルの数を返します。

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:AS DAF String VBA エクセル
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●150ポイント ベストアンサー

こんな感じでどうでしょうか。

Function GetRange(serchKey As String, MaxNum As Long) As Range
 Dim r1 As Range
 Dim r2 As Range
 Dim str As String
 serchKey = StrConv(StrConv(serchKey, vbNarrow), vbLowerCase)
 MaxNum = 0
 For Each r1 In Selection
 str = StrConv(StrConv(r1.Value, vbNarrow), vbLowerCase)
 If InStr(1, str, serchKey) > 0 Then
 If r2 Is Nothing Then
 Set r2 = r1
 Else
 Set r2 = Union(r2, r1)
 End If
 MaxNum = MaxNum + 1
 If MaxNum >= 100 Then
 Exit For
 End If
 End If
 Next
 Set GetRange = r2
End Function

引数MaxNumは参照渡しなので、変数を渡せばその変数に個数が入ります。

一つも無い場合はnothingが返ります。


例えばこんなコードで呼び出すことができます。

Sub test()
 Dim i As Long
 If GetRange("FdF’D", i) Is Nothing Then
 MsgBox "Nothing"
 Else
 MsgBox "セルのアドレスは" & vbNewLine & GetRange("FdF’D", i).Address
 MsgBox "セルの個数は" & vbNewLine & i
 End If
End Sub
◎質問者からの返答

いつもありがとうございます。

早速試してみたいと思います。


2 ● ardarim
●100ポイント

Excelの場合ですと、実は例題の時点でかなりきついです。

Excel(Windows)の標準機能では、半角の「'」と全角の「’」は同一視されません。これは手動で(Ctrl+Fで)検索した場合でも同様です。

※Windowsだと"'"の全角は"’"(シフトJISの8166)ではなく"?"(シフトJISのFA56)と見なされます。


サンプルはこの「'」と「’」を同一視する仕組みを入れているため、少し複雑になっています。

Option Explicit

Sub test()

 Dim r() As Variant
 Dim mx As Long
 
 Cells.Select
 
 r = GetRange("FdF’D", mx)

 MsgBox "一致したセル数=" & mx

End Sub

Function GetRange(searchKey As String, MaxNum As Long) As Variant

 Dim cl As Range
 Dim cl_top As Range
 Dim result As Variant
 Dim sKey(3) As String
 Dim i As Long, j As Long, m As Long
 
 m = 1
 sKey(1) = searchKey
 If InStr(1, searchKey, "'") > 0 Then
 m = m + 1
 sKey(m) = Replace(searchKey, "'", "’")
 End If
 If InStr(1, searchKey, "’") > 0 Then
 m = m + 1
 sKey(m) = Replace(searchKey, "’", "'")
 End If
 
 ReDim result(100)
 
 MaxNum = 0
 For i = 1 To m
 Set cl = Nothing
 Set cl_top = Nothing
 Do While MaxNum < 100
 If cl Is Nothing Then
 Set cl = Selection.Find(sKey(i), , , xlPart, , xlNext, False, False)
 Else
 Set cl = Selection.Find(sKey(i), cl, , xlPart, , xlNext, False, False)
 End If
 If cl Is Nothing Then Exit Do
 If cl_top Is Nothing Then
 Set cl_top = cl
 Else
 If cl_top.Address = cl.Address Then Exit Do
 End If
 For j = 1 To MaxNum
 If result(j).Address = cl.Address Then Exit For
 Next j
 If j > MaxNum Then
 Set result(MaxNum + 1) = cl
 MaxNum = MaxNum + 1
 End If
 Loop
 Next i
 
 ReDim Preserve result(MaxNum)
 
 GetRange = result
 
End Function
◎質問者からの返答

どうもありがとうございます。

お二方のおかげで良いプログラムが動作しそうです。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ