Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


13328 / 13644 ツリー ←次へ | 前へ→

【5919】3次元の検索を早く行う方法をどなたか知りませんか。 まこさん 03/6/9(月) 15:38 質問
【5920】Re:3次元の検索を早く行う方法をどなたか... 角田 03/6/9(月) 16:03 回答
【5921】Re:3次元の検索を早く行う方法をどなたか知... ぴかる 03/6/9(月) 16:09 回答
【5925】Re:3次元の検索を早く行う方法をどなたか知... Hirofumi 03/6/9(月) 20:31 回答
【5926】Re:3次元の検索を早く行う方法をどなたか知... Hirofumi 03/6/9(月) 21:10 発言
【5929】Re:3次元の検索を早く行う方法をどなたか知... ichinose 03/6/10(火) 1:11 回答
【5935】Re:3次元の・・・・<みんさんご回答ありが... まこさん 03/6/10(火) 13:40 お礼

【5919】3次元の検索を早く行う方法をどなたか知...
質問  まこさん  - 03/6/9(月) 15:38 -

引用なし
パスワード
   こんにちわ。ご覧いただきありがとうございます。
早速ですが、下のような表があります。

A  B  C
1  2  3
3  3  4
3  4  5
4  5  6
5  6  7

この表で、例えば A=3,B=4,C=5を満たす行は何行目かをマクロで検索したいのですが。
複数条件が設定できて1度で検索できるような方法を本を見て探していますが見つかりません。その他いろいろな方法で解決できる方法がお分かりの方ご教授をぜひお願いいたします。

【5920】Re:3次元の検索を早く行う方法をどなたか...
回答  角田 WEB  - 03/6/9(月) 16:03 -

引用なし
パスワード
   こんにちは。
A/B/C列のデータを連結した検索キー用の列を用意すれば、
単純にMATCHで出来ますよ。

D列に
="a" & TEXT(A1,"000") & TEXT(B1,"00") & TEXT(C1,"0000")
と入れておけば↓になります(先頭の"a"は先頭のゼロを残す為に文字列
にする為に付けただけです)。

A  B  C  D
1  2  3  a001020003
3  3  4  a003030004
3  4  5  a003040005
4  5  6  a004050006
5  6  7  a005060007

=MATCH("a003040005",D1:D5,0)

キーを作成する時に大事なのは、各項目(列データ)の桁を揃える事です。
数値ならTEXT関数で↑のように編集し、文字列なら
 LEFT((A1&REPT(" ",10)),5)
という風に末尾に空白を連結してから、先頭から固定桁で取り出します。

検索する時は、キー作成時と同じ方法で編集したデータで検索します。
一般機能でもVBAでも基本は一緒です。

【5921】Re:3次元の検索を早く行う方法をどなたか...
回答  ぴかる  - 03/6/9(月) 16:09 -

引用なし
パスワード
   まこさんさん、こんにちは。

こんなんでどでしょ?。こっちは、マクロ板です。
角田さん版も、今から確認させて頂きます。

Sub TEST()

Dim 数値A As Integer
Dim 数値B As Integer
Dim 数値C As Integer
Dim I As Long
  
  数値A = InputBox("数値Aを入力してちょうだい!", "検索値入力")
  数値B = InputBox("数値Bを入力してちょうだい!", "検索値入力")
  数値C = InputBox("数値Cを入力してちょうだい!", "検索値入力")

  For I = 1 To Range("A1").End(xlDown).Row
    If (数値A = Range("A" & I)) And (数値B = Range("B" & I)) And (数値C = Range("C" & I)) Then
      Range("A" & I & ":C" & I).Select
      MsgBox "一致行は、" & I & "です。"
      Exit Sub
    End If
  Next
  
  MsgBox "該当データは、無かったよ。"

End Sub

【5925】Re:3次元の検索を早く行う方法をどなたか...
回答  Hirofumi E-MAIL  - 03/6/9(月) 20:31 -

引用なし
パスワード
   面白そうなので私も作って見ました
A列順の、B列順の、C列順でソートされて要る事が条件
直接セル上で2分探索を行っているのでMatchよりは低速ですが
セルを直接にリニアサーチするより速いと思います
このコードでは、B、C列はOffsetで見ているので探索範囲(rngScope)は、
A列として与えてください
例では、探索Key1、Key2、Key3をリテラルとして入れていますが、
もちろん変数で受け渡してもOkです
また、A、B、C列の値は3桁までを想定していますが
それを変更すつのは、
Function BinarySearchCellsの
  '桁数
  Const lngPlace As Long = 3
を変更して下さい

Public Sub Test2()

  Dim rngScope As Range
  Dim vntKey As Variant
  Dim lngFind As Long
  
  Set rngScope = Range(Cells(6, 1), Cells(65536, 1).End(xlUp))
  
  lngFind = BinarySearchCells(4, 5, 6, rngScope)
  If lngFind <> -1 Then
    MsgBox lngFind & "行です"
  Else
    MsgBox "探索値が有りません"
  End If
  
  Set rngScope = Nothing
  
End Sub

Public Function BinarySearchCells(vntKey1 As Variant, _
                vntKey2 As Variant, _
                vntKey3 As Variant, _
                rngScope As Range) As Long

'  二進探索セル版

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  Dim vntTmp As Variant
  Dim vntSearch As Variant
  Dim lngStartAdd As Long
  '桁数
  Const lngPlace As Long = 3
  
  '数値の場合
  vntSearch = vntKey1 * 10 ^ (lngPlace * 2) _
          + vntKey2 * 10 ^ lngPlace _
            + vntKey3
  '文字列の場合
'  vntSearch = Right(String(lngPlace, "0") _
'            & vntKey1, lngPlace) _
'          & Right(String(lngPlace, "0") _
'              & vntKey2, lngPlace) _
'            & Right(String(lngPlace, "0") _
'                & vntKey3, lngPlace)
  With rngScope
    lngStartAdd = .Row - 1
    lngLow = 1
    lngHigh = .Rows.Count
    Do While lngLow <= lngHigh
      lngMiddle = (lngLow + lngHigh) \ 2
      With .Cells(lngMiddle)
        '数値の場合
        vntTmp = .Offset(, 0).Value * 10 ^ (lngPlace * 2) _
              + .Offset(, 1).Value * 10 ^ lngPlace _
                + .Offset(, 2).Value
        '文字列の場合
'        vntTmp = Right(String(lngPlace, "0") _
'                & .Offset(, 0).Value, lngPlace) _
'              & Right(String(lngPlace, "0") _
'                  & .Offset(, 1).Value, lngPlace) _
'                & Right(String(lngPlace, "0") _
'                    & .Offset(, 2).Value, lngPlace)
      End With
      Select Case vntSearch
        Case Is > vntTmp
          lngLow = lngMiddle + 1
        Case Is < vntTmp
          lngHigh = lngMiddle - 1
        Case Is = vntTmp
          lngLow = lngMiddle + 1
          lngHigh = lngMiddle - 1
      End Select
    Loop
  End With
  If lngLow = lngHigh + 2 Then
    BinarySearchCells = lngStartAdd + lngMiddle
  Else
    BinarySearchCells = -1
  End If

End Function

【5926】Re:3次元の検索を早く行う方法をどなたか...
発言  Hirofumi E-MAIL  - 03/6/9(月) 21:10 -

引用なし
パスワード
   いけね、Testした時のまんま乗っけてしまた
データがA1から始まるなら以下の部分を修正して下さい

>  Set rngScope = Range(Cells(6, 1), Cells(65536, 1).End(xlUp))



  Set rngScope = Range(Cells(1, 1), Cells(65536, 1).End(xlUp))

にして下さい

【5929】Re:3次元の検索を早く行う方法をどなたか...
回答  ichinose  - 03/6/10(火) 1:11 -

引用なし
パスワード
   こんばんは。
私も作ってみました。
D列を作業列にしました。
'=========================================================
Sub Excel_Search()
Dim rng As Range
Dim f_con(1 To 3) As String
Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
f_con(1) = "=3"
f_con(2) = "=4"
f_con(3) = "=5"
With rng
 .Offset(0, 3).Formula = "=IF((RC[-3]" & f_con(1) & ")*(RC[-2]" & f_con(2) & ")*(RC[-1]" & f_con(3) & ")<>0,ROW(),"""")"
 .Offset(0, 3).Value = .Offset(0, 3).Value
 Set ans = ad_specialcells(.Offset(0, 3))
 If Not ans Is Nothing Then
   disp = "答えは :" & ans.Count & vbCrLf
   For Each cans In ans
    disp = disp & cans.Value & "行" & vbCrLf
    Next
   MsgBox disp
 Else
   MsgBox "解なし"
   End If
 .Offset(0, 3).Value = ""
 End With
End Sub
'==============================================================
Function ad_specialcells(rng As Range) As Range
  On Error Resume Next
  Set ad_specialcells = Nothing
  Set ad_specialcells = rng.SpecialCells(xlCellTypeConstants)
  On Error GoTo 0
End Function

【5935】Re:3次元の・・・・<みんさんご回答あり...
お礼  まこさん  - 03/6/10(火) 13:40 -

引用なし
パスワード
   こんにちわ。
みなさんから回答いただきありがとうございます。
これから検証させていただきます。
ありがとうございました。

13328 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free