Excel VBA質問箱 IV

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

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


73988 / 76732 ←次へ | 前へ→

【7215】取り合えずこんな物でも?
回答  Hirofumi E-MAIL  - 03/8/26(火) 20:57 -

引用なし
パスワード
   横から失礼します
取り合えず、速くないけどこんなかな?
社名、人名、顧客コードの最大桁数+1を、RowSearchの定数の設定して下さい
取り合えず、各4桁に設定してあります
時間が無かったので、Testを行っていません
上手く行かなかったらゴメン

以下を同一の標準モジュールに記述して下さい

Public Sub Test()

  Dim i As Long
  Dim vntData As Variant
  Dim rngScope As Range
  Dim lngFound As Long
  
  'シートAのデータを配列に取得
  With Worksheets("シートA")
    vntData = Range(.Cells(2, 1), _
          .Cells(65536, 4).End(xlUp)).Value
  End With
  
  'シートBを探索
  With Worksheets("シートB")
    '探索範囲を取得
    Set rngScope = Range(.Cells(2, 1), _
            .Cells(65536, 3).End(xlUp)).Value
    'シートAのデータの終りまで繰り返し
    For i = 1 To UBound(vntData, 1)
      '社名、人名、顧客コードをKeyに探索範囲より探索
      lngFound = RowSearch(vntData(i, 1), vntData(i, 2), _
                    vntData(i, 3), rngScope)
      'もし、Keyと同じ物が有った場合
      If lngFound <> -1 Then
        'E列にシートAのD列の値を代入
        .Cells(lngFound, 5).Value = vntData(i, 4)
      End If
    Next i
  End With
  
  Set rngScope = Nothing
  
End Sub

Private Function RowSearch(vntKey1 As Variant, _
                vntKey2 As Variant, _
                vntKey3 As Variant, _
                rngScope As Range) As Long

'  二進探索(複数探索Key)

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  Dim vntTmp As Variant
  Dim lngStartAdd As Long
  Dim vntKey As Variant
  
  Const lngLen1 As Long = 4 '社名の最大桁数+1
  Const lngLen2 As Long = 4 '人名の最大桁数+1
  Const lngLen3 As Long = 4 '顧客コードの最大桁数+1
  
  vntKey = Right(String(lngLen1, " ") & vntKey1, lngLen1) _
      & Right(String(lngLen2, " ") & vntKey2, lngLen2) _
      & Right(String(lngLen3, " ") & vntKey3, lngLen3)
  
  With rngScope
    lngStartAdd = .Row - 1
    lngLow = 1
    lngHigh = .Rows.Count
    Do While lngLow <= lngHigh
      lngMiddle = (lngLow + lngHigh) \ 2
      vntTmp = Right(String(lngLen1, " ") _
            & .Cells(lngMiddle, 1).Value, lngLen1) _
          & Right(String(lngLen2, " ") _
            & .Cells(lngMiddle, 2).Value, lngLen2) _
          & Right(String(lngLen3, " ") _
            & .Cells(lngMiddle, 3).Value, lngLen3)
      Select Case vntKey
        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
    RowSearch = lngStartAdd + lngMiddle
  Else
    RowSearch = -1
  End If

End Function
1 hits

【7182】同一データの抽出について 乾燥肌 03/8/26(火) 1:13 質問
【7184】Re:同一データの抽出について INA 03/8/26(火) 8:21 回答
【7214】訂正させて頂きます。 乾燥肌 03/8/26(火) 19:46 回答
【7215】取り合えずこんな物でも? Hirofumi 03/8/26(火) 20:57 回答
【7256】ありがとうございました 乾燥肌 03/8/28(木) 1:36 お礼
【7260】Re:取り合えずこんな物でも? INA 03/8/28(木) 9:53 お礼

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