Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

65480 / 76807

←次へ　｜　前へ→


	【15902】別シートを次々処理したく

Hirofumi - 04/7/11(日) 11:31 -


	引用なし

	パスワード

>この現在使用しているシートのみでなく､
>別シートを次々処理したく､

と言う事なら、発想を変えて、こんなのでも言いと思いますが？
今度は、以下のコードを「**参照シート**」の有るBookの標準モジュールに記述して下さい
まず、「**参照シート**」の有るBookを開きます
次に、処理したいBookを開き、処理したいシートをActiveにします
「DataSearch2」を実行します
処理したBookを閉じ、次に処理したいBookを開き同様にします

Option Explicit

Public Sub DataSearch2()

　　Const lngRowEnd As Long = 65536
　　
　　Dim i As Long
　　Dim rngData As Range
　　Dim vntResult As Variant
　　Dim vntKeys As Variant
　　Dim rngKyes As Range
　　
　　
　　'画面更新の停止
　　Application.ScreenUpdating = False
　　
　　'データ範囲を取得
　　With ThisWorkbook.Worksheets("参照シート")
　　　　Set rngData = Range(.Cells(2, "A"), _
　　　　　　　　.Cells(lngRowEnd, "A").End(xlUp))
　　End With
　　
　　'コードの有る範囲を設定
　　With ActiveSheet
　　　　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) = RowSearchBin(vntKeys(i, 1), rngData)
　　Next i
　　
　　'結果を出力
　　With rngKyes
　　　　.Offset(, 1).Resize(.Rows.Count).Value = vntResult
　　End With
　　
　　Set rngKyes = Nothing
　　Set rngData = Nothing
　　
　　Application.ScreenUpdating = True
　　
　　Beep
　　MsgBox "処理が完了しました"
　　　　
End Sub

Private Function RowSearchBin(vntKey As Variant, _
　　　　　　　　　　　　rngScope As Range) As Variant

　　Dim vntFind As Variant
　　Dim lngDataTop As Long
　　
　　'Matchによる二分探索
　　vntFind = Application.Match(vntKey, rngScope, 1)
　　'もし、エラーで無いなら
　　If Not IsError(vntFind) Then
　　　　'もし、Key値と探索位置の値が等しいなら
　　　　If vntKey = rngScope(vntFind).Value Then
　　　　　　'戻り値として、行位置を代入
　　　　　　RowSearchBin = rngScope(vntFind, 2).Value
　　　　End If
　　End If
　　
End Function

1 hits

▼

【15876】データ抽出について 初心者 04/7/9(金) 23:12