Excel VBA質問箱 IV

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

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


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

57100 / 76732

←次へ　｜　前へ→


	【24372】Re:表引きの定石をご教示下さい

Hirofumi - 05/4/20(水) 20:22 -


	引用なし

	パスワード

データが、数万行も有ると
最初のコードでは、えらく遅いと思います
因って、少し速くなる様にして見ました
ただし、今回のFunction DataReference2は、
ユーザー定義関数として使えませんので宜しく

Option Explicit

Public Sub Sample2()

'　マクロとして使う場合

　　Dim i As Long
　　Dim lngPos As Long
　　Dim rngWeight As Range
　　Dim rngCode As Range
　　Dim lngRows As Long
　　Dim vntList As Variant
　　Dim vntData As Variant
　　Dim vntResult As Variant
　　
　　'表の先頭セル位置（「品名コード/重量(g)」の書いて有るセル）
　　With Worksheets("Sheet2").Cells(1, "A")
　　　　'重量(g)の書いて有る列数を取得
　　　　lngPos = .End(xlToRight).Column - .Column
　　　　'重量(g)の書いて有る範囲を設定
　　　　Set rngWeight = .Offset(, 1).Resize(, lngPos)
　　　　'品名コードの有る行数を取得
　　　　lngPos = .End(xlDown).Row - .Row
　　　　'品名コードの有る範囲を設定
　　　　Set rngCode = .Offset(1).Resize(lngPos)
　　　　'表のデータ範囲を配列に取得
　　　　vntList = .Offset(1, 1).Resize(lngPos, rngWeight.Columns.Count).Value
　　End With
　　
　　'結果表の先頭セル位置（「品名コード」の書いて有るセル）
　　With Worksheets("Sheet1").Cells(1, "A")
　　　　'データ行数を取得
　　　　lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
　　　　'結果出力用配列を確保
　　　　ReDim vntResult(1 To lngRows, 1 To 1)
　　　　'データ先頭から最終まで繰り返し
　　　　For i = 1 To lngRows
　　　　　　'データ1行分を配列に取得
　　　　　　vntData = .Offset(i).Resize(, 3).Value
　　　　　　'探索結果を出力用配列に代入
　　　　　　vntResult(i, 1) = DataReference2(vntData(1, 1), vntData(1, 3), _
　　　　　　　　　　　　　　　　　　　　　　　　　　rngCode, rngWeight, vntList)
　　　　Next i
　　　　'結果用配列を出力
　　　　.Offset(1, 3).Resize(lngRows).Value = vntResult
　　End With
　　
　　Beep
　　MsgBox "処理が完了しました"
　　
End Sub

Private Function DataReference2(vntCode As Variant, _
　　　　　　　　　　　　　　　　vntWeight As Variant, _
　　　　　　　　　　　　　　　　rngCode As Range, _
　　　　　　　　　　　　　　　　rngWeight As Range, _
　　　　　　　　　　　　　　　　vntList As Variant) As Variant
　　
　　Dim lngFoundCode As Long
　　Dim lngFoundWeight As Long
　　Dim lngOver As Long
　　
　　
　　'商品コードの位置を探索
　　lngFoundCode = DataSearch(vntCode, rngCode)
　　'該当商品コードが無い場合
　　If lngFoundCode = 0 Then
　　　　DataReference2 = "該当商品コード無し"
　　　　Exit Function
　　End If
　　
　　'重量(g)の位置を探索
　　lngFoundWeight = DataSearch(vntWeight, rngWeight, lngOver)
　　'該当重量が無い場合
　　If lngFoundWeight = 0 Then
　　　　If lngOver = 0 Then
　　　　　　DataReference2 = "該当重量無し"
　　　　　　Exit Function
　　　　Else
　　　　　　'Key値を超える最小値のある位置に
　　　　　　lngFoundWeight = lngOver
　　　　End If
　　End If
　　
　　'発見した、行列位置の値を戻り値として返す
　　With rngCode
　　　　DataReference2 = vntList(lngFoundCode, lngFoundWeight)
　　End With
　　
End Function

Private Function DataSearch(vntKey As Variant, _
　　　　　　　　　　　　rngScope As Range, _
　　　　　　　　　　　　Optional lngOver As Long) As Long

　　Dim vntFind As Variant
　　
　　If vntKey = "" Then
　　　　Exit Function
　　End If
　　
　　'Matchによる二分探索
　　vntFind = Application.Match(vntKey, rngScope, 1)
　　'もし、エラーで無いなら
　　If Not IsError(vntFind) Then
　　　　'もし、Key値と探索位置の値が等しいなら
　　　　If vntKey = rngScope(vntFind).Value Then
　　　　　　'戻り値として、行位置を代入
　　　　　　DataSearch = vntFind
　　　　End If
　　　　'Key値を超える最小値のある行
　　　　If vntFind = rngScope.Count Then
　　　　　　lngOver = 0
　　　　Else
　　　　　　lngOver = vntFind + 1
　　　　End If
　　Else
　　　　lngOver = 1
　　End If
　　
End Function

0 hits

▼

【24267】表引きの定石をご教示下さい daihan 05/4/18(月) 9:23