Excel VBA質問箱 IV

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

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


65432 / 76738 ←次へ | 前へ→

【15881】Re:データ抽出について
回答  Hirofumi  - 04/7/10(土) 0:42 -

引用なし
パスワード
   各シートのレイアウトは、以下の様に成っているとします

**現在シート**
  A   B
1 コード 商品名
2  1
3  5
4  3
5  4

**参照シート**
   A    B
1  コード  商品名
2   1    りんご
3   2    ばなな
4   3    なし
5   4    すいか
6   5    ぶどう
7   6    もも

参照シートは、コードでソートされている物とします

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

Option Explicit
Option Compare Text

Public Sub DataSearch()

  Const lngRowEnd As Long = 65536
  
  Dim i As Long
  Dim vntData As Variant
  Dim vntDataFile As Variant
  Dim blnExist As Boolean
  Dim strName As String
  Dim vntResult As Variant
  Dim vntKeys As Variant
  Dim rngKyes As Range
  
  '"参照シート"の有るファイルを取得
  If Not GetReadFile(vntDataFile, _
          ThisWorkbook.Path, False) Then
    Exit Sub
  End If
  
  '画面更新の停止
  Application.ScreenUpdating = False
  
  strName = GetFileName(vntDataFile)
  With Workbooks
    For i = 1 To .Count
      If .Item(i).Name = strName Then
        blnExist = True
        Exit For
      End If
    Next i
    If blnExist Then
      .Item(strName).Activate
    Else
      '"参照シート"の有るファイルをOpen
      .Open (vntDataFile)
    End If
  End With
  'データを取得
  With Workbooks(strName).Worksheets("参照シート")
      vntData = Range(.Cells(2, "A"), _
      .Cells(lngRowEnd, "B").End(xlUp)).Value
  End With
  '入力ファイルをClose
  Workbooks(strName).Close
  
  'コードの有る範囲を設定
  With ThisWorkbook.Worksheets("現在シート")
    Set rngKyes = Range(.Cells(2, "A"), _
            .Cells(lngRowEnd, "A").End(xlUp))
  End With
  'コードを配列に取得
  vntKeys = rngKyes.Value
  '結果用配列を確保
  ReDim vntResult(1 To UBound(vntKeys, 1), 1 To 1)
  
  'コードの先頭から終りまで繰り返し
  For i = 1 To UBound(vntKeys, 1)
    'コードを探索
    vntResult(i, 1) = BinarySearch(vntKeys(i, 1), vntData)
  Next i
  
  '結果を出力
  With rngKyes
    .Offset(, 1).Resize(.Rows.Count).Value = vntResult
  End With
  
  Set rngKyes = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
    
End Sub

Private Function BinarySearch(vntKey As Variant, _
              vntScope As Variant) As Variant

'  二進探索

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  
  lngLow = LBound(vntScope, 1)
  lngHigh = UBound(vntScope, 1)
  
  Do While lngLow <= lngHigh
    lngMiddle = (lngLow + lngHigh) \ 2
    Select Case vntScope(lngMiddle, 1)
      Case Is < vntKey
        lngLow = lngMiddle + 1
      Case Is > vntKey
        lngHigh = lngMiddle - 1
      Case Is = vntKey
        lngLow = lngMiddle + 1
        lngHigh = lngMiddle - 1
    End Select
  Loop
  
  If lngLow = lngHigh + 2 Then
    BinarySearch = vntScope(lngMiddle, 2)
  Else
    BinarySearch = Empty
  End If
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "Excel File (*.xls),*.xls," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  
  GetFileName = Mid(strName, i + 1)
    
End Function

0 hits

【15876】データ抽出について 初心者 04/7/9(金) 23:12 質問
【15879】Re:データ抽出について Asaki 04/7/9(金) 23:30 回答
【15886】Re:データ抽出について Asaki 04/7/10(土) 13:31 回答
【15881】Re:データ抽出について Hirofumi 04/7/10(土) 0:42 回答
【15890】Re:データ抽出について 初心者 04/7/10(土) 21:30 質問
【15891】Re:データ抽出について かみちゃん 04/7/10(土) 22:10 回答
【15892】Re:データ抽出について Hirofumi 04/7/10(土) 23:13 回答
【15898】Re:データ抽出について 初心者 04/7/11(日) 9:39 質問
【15901】Re:データ抽出について Hirofumi 04/7/11(日) 10:57 回答
【15902】別シートを次々処理したく Hirofumi 04/7/11(日) 11:31 回答
【15982】Re:別シートを次々処理したく 初心者 04/7/13(火) 21:26 質問
【15984】Re:別シートを次々処理したく Hirofumi 04/7/13(火) 21:59 回答
【16040】Re:別シートを次々処理したく Hirofumi 04/7/14(水) 21:40 回答
【16116】Re:別シートを次々処理したく 初心者 04/7/16(金) 20:48 お礼
【16207】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/20(火) 21:28 質問
【16208】Re:別シートを次々処理したく 以前の続き... Hirofumi 04/7/20(火) 21:59 発言
【16214】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/21(水) 6:30 発言
【16241】Re:別シートを次々処理したく 以前の続き... Hirofumi 04/7/21(水) 21:04 回答
【16309】Re:別シートを次々処理したく 以前の続き... 初心者 04/7/24(土) 22:28 お礼
【15897】Re:データ抽出について @MS1 04/7/11(日) 9:28 発言

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