Excel VBA質問箱 IV

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

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


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

57175 / 76732

←次へ　｜　前へ→


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

Hirofumi - 05/4/18(月) 21:48 -


	引用なし

	パスワード

VBAでやるならこんなでも善いかな？
Sheet1、Sheet2は、ウッシさんの提示したレイアウトと同じとします

Option Explicit

Public Sub Sample()

'　マクロとして使う場合

　　Dim i As Long
　　Dim lngPos As Long
　　Dim rngWeight As Range
　　Dim rngCode As Range
　　Dim lngRows As Long
　　　　
　　'表の先頭セル位置（「品名コード/重量(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)
　　End With
　　
　　'結果表の先頭セル位置（「品名コード」の書いて有るセル）
　　With Worksheets("Sheet1").Cells(1, "A")
　　　　'データ行数を取得
　　　　lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
　　　　'データ先頭から最終まで繰り返し
　　　　For i = 1 To lngRows
　　　　　　.Offset(i, 3).Value = DataReference(.Offset(i).Value, _
　　　　　　　　　　　　　　　　　　.Offset(i, 2).Value, rngCode, rngWeight)
　　　　Next i
　　End With
　　
　　Beep
　　MsgBox "処理が完了しました"
　　
End Sub

'ユーザー定義関数として使う場合は、
'vntCodeに品名コードのセルを指定
'vntWeightに重量のセルを指定
'rngCodeにSheet2の商品コードの書いて有るセル範囲を指定
'rngWeightにSheet2の重量の書いて有る範囲を指定
Public Function DataReference(vntCode As Variant, _
　　　　　　　　　　　　　　　　vntWeight As Variant, _
　　　　　　　　　　　　　　　　rngCode As Range, _
　　　　　　　　　　　　　　　　rngWeight As Range) As Variant
　　
　　Dim lngFoundCode As Long
　　Dim lngFoundWeight As Long
　　Dim lngOver As Long
　　
　　
　　'商品コードの位置を探索
　　lngFoundCode = DataSearch(vntCode, rngCode)
　　'該当商品コードが無い場合
　　If lngFoundCode = 0 Then
　　　　DataReference = "該当商品コード無し"
　　　　Exit Function
　　End If
　　
　　'重量(g)の位置を探索
　　lngFoundWeight = DataSearch(vntWeight, rngWeight, lngOver)
　　'該当重量が無い場合
　　If lngFoundWeight = 0 Then
　　　　If lngOver = 0 Then
　　　　　　DataReference = "該当重量無し"
　　　　　　Exit Function
　　　　Else
　　　　　　'Key値を超える最小値のある位置に
　　　　　　lngFoundWeight = lngOver
　　　　End If
　　End If
　　
　　'発見した、行列位置の値を戻り値として返す
　　With rngCode
　　　　DataReference = .Item(lngFoundCode).Offset(, lngFoundWeight).Value
　　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

1 hits

▼

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