| |
こんばんは。
>FindメソッドとFindnextメソッドを使い、先に検索だけを行い、
>見つかったセルをUnionメソッドを使って、
>セル範囲の集合体にしておきます。
と言ってしまったので、Unionでの順序の違い程度は、いいじゃない と、
思っていたので良いと思ってましたが、駄目ですか・・・。
だったら、どっかで並べ替えるしかないですねえ
新規ブックにて
標準モジュール（Module1）に
既作のFindメソッドの汎用プロシジャー
'=================================================================
Option Explicit
Function get_findcell(Optional ByVal f_v As Variant = "", _
Optional ByVal rng As Range = Nothing, _
Optional ByVal strng As Range = Nothing, _
Optional ByVal alookin As XlFindLookIn = -4163, _
Optional ByVal alookat As XlLookAt = 1, _
Optional ByVal aso As XlSearchOrder = 1, _
Optional ByVal asd As XlSearchDirection = 1, _
Optional ByVal mc As Boolean = False, _
Optional ByVal mb As Boolean = True) As Range
'指定された値でセル範囲を検索し､該当するセルを取得する
'input : f_v 検索する値
' rng 検索する範囲
' strng 検索開始するセル（実際には、このセルの次から検索する）
' alookin 検索対象 xlvalues,xlformulas,xlcomments
' alookat: :検索方法 1-完全一致 2-部分一致
' aso : 検索順序 1 行 2 列
' asd : 検索方向 1 Xlnext 2 XlPrevious
' mc : 大文字・小文字の区別 False しない True する
' mb : 半角と全角を区別 True する False しない
'output:get_findcell 見つかったセル(見つからなかったときはNothingが返る)
Static 検索範囲 As Range
Static 最初に見つかったセル As Range
Static 直前に見つかったセル As Range
Static 検索方向 As XlSearchDirection
Dim app As Object
If Not rng Is Nothing Then
If Val(Application.Version) > 9 Then
Set app = Application
app.FindFormat.Clear
Set app = Nothing
End If
Set 検索範囲 = rng
If strng Is Nothing Then
If asd = 1 Then
Set strng = 検索範囲.Cells(検索範囲.Rows.Count, 検索範囲.Columns.Count)
Else
Set strng = 検索範囲.Cells(1, 1)
End If
End If
検索範囲.Parent.Columns(1).Find ""
End If
If f_v <> "" Then
Set get_findcell = 検索範囲.Find(f_v, strng, alookin, alookat, aso, asd, mc, mb)
If Not get_findcell Is Nothing Then
Set 最初に見つかったセル = get_findcell
Set 直前に見つかったセル = get_findcell
検索方向 = asd
End If
Else
If 検索方向 = xlNext Then
Set get_findcell = 検索範囲.FindNext(直前に見つかったセル)
Else
Set get_findcell = 検索範囲.FindPrevious(直前に見つかったセル)
End If
If Not get_findcell Is Nothing Then
If get_findcell.Address = 最初に見つかったセル.Address Then
Set get_findcell = Nothing
Else
Set 直前に見つかったセル = get_findcell
End If
End If
End If
End Function
別の標準モジュール（Module2）に
'=================================================================
Sub samp1()
Dim g0 As Long
Dim ans As Variant
Dim ret As Long
Dim mes As Variant
Dim g1 As Long
mes = Array("", "データの終わりです", "データの始めです")
ans = 検索EX(ActiveSheet.UsedRange, Array("竹内結子", "坂井真紀", "星奈々")) 'この配列に複数の検索データを記述
If TypeName(ans) <> "Boolean" Then
g1 = 0
g0 = LBound(ans, 1)
ret = vbYes
Do Until ret = vbCancel
Cells(ans(g0, 1), ans(g0, 2)).Select
ret = MsgBox(mes(g1) & vbCrLf & _
"はい 次のデータ" & vbCrLf & _
"いいえ 前のデータ" & vbCrLf & _
"キャンセル 検索の終わり", vbYesNoCancel)
If ret = vbYes Then
If g0 + 1 > UBound(ans, 1) Then
g1 = 1
Else
g1 = 0
g0 = g0 + 1
End If
ElseIf ret = vbNo Then
If g0 - 1 < LBound(ans, 1) Then
g1 = 2
Else
g0 = g0 - 1
g1 = 0
End If
End If
Loop
End If
End Sub
'==============================================================
Function 検索EX(rng As Range, f_str As Variant) As Variant
Dim dic As Object
Dim fr As Range
Dim g0 As Long
Dim wk As Variant
検索EX = False
Set dic = CreateObject("scripting.dictionary")
For g0 = LBound(f_str) To UBound(f_str)
Set fr = get_findcell(f_str(g0), rng, , xlValues, xlPart, xlByRows, xlNext)
Do Until fr Is Nothing
dic(Join(Array(fr.Row, fr.Column), " ")) = Array(fr.Row, fr.Column)
Set fr = get_findcell()
Loop
Next
If dic.Count > 0 Then
Application.ScreenUpdating = False
With Workbooks.Add
With .Worksheets(1)
With .Range(.Cells(1, "a"), .Cells(dic.Count, "a")).Resize(, 2)
.Value = Application.Transpose(Application.Transpose(dic.items))
With .Resize(, 2)
.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal
検索EX = .Value
End With
End With
End With
.Close False
End With
Application.ScreenUpdating = True
End If
End Function
別の標準モジュール（Module3）に
サンプルデータ作成プロシジャー
Sub mk_datasmp()
Range("a1").Value = "竹内結子"
Range("c1").Value = "星奈々"
Range("i21").Value = "竹内結子 星奈々"
Range("ik65512").Value = "坂井真紀"
Range("iv65536").Value = "竹内結子"
Range("a1").Select
End Sub
操作手順
mk_datasmpを実行してください。サンプルデータを表示します。
samp1を実行してください。
はいで 順検索 いいえで 逆検索 キャンセルで 検索終了です。
|
|
ichinose
- 11/10/7(金) 19:14 -
