お気持ちのみですが全部で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は、検索に一致したセルの数を返します。

回答の条件
  • 1人2回まで
  • 登録:2009/02/21 14:30:51
  • 終了:2009/02/26 13:53:44

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/21 15:25:14

ポイント150pt

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

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
id:ReoReo7

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

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

2009/02/21 18:27:26

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/21 15:25:14ここでベストアンサー

ポイント150pt

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

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
id:ReoReo7

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

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

2009/02/21 18:27:26
id:ardarim No.2

ardarim回答回数892ベストアンサー獲得回数1422009/02/22 03:16:24

ポイント100pt

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
id:ReoReo7

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

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

2009/02/26 13:53:26

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません