Excel VBA質問箱 IV

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

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


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

22853 / 76732

←次へ　｜　前へ→


	【59254】Re:表引きをしたい

Hirofumi - 08/12/3(水) 20:24 -


	引用なし

	パスワード

こんなので出来そうですが

マスタ表がSheet1に有り
結果がSheet2に有る物とします

Option Explicit

Public Sub Sample()

　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngColumns As Long
　　Dim lngRow As Long
　　Dim lngColumn As Long
　　Dim rngTable As Range
　　Dim rngResult As Range
　　Dim vntData As Variant
　　Dim rngDiameter As Range
　　Dim rngWeight As Range
　　Dim strProm As String

　　'◆マスタ表の先頭セル位置を基準とする(表の左上隅のセル位置)
　　Set rngTable = Worksheets("Sheet1").Cells(1, "A")
　　
　　'◆定数を出力する位置(「重量」の列見出しのセル位置)
　　Set rngResult = Worksheets("Sheet2").Cells(1, "A")
　　
　　With rngTable
　　　　'行数の取得
　　　　lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
　　　　If lngRows <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'列数の取得
　　　　lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column
　　　　If lngColumns <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'径の値の範囲を取得
　　　　Set rngDiameter = .Offset(1).Resize(lngRows)
　　　　'重量の値の範囲を取得
　　　　Set rngWeight = .Offset(, 1).Resize(, lngColumns)
　　End With
　　
　　With rngResult
　　　　'行数の取得
　　　　lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
　　　　If lngRows <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'重量、径の値を配列に取得
　　　　vntData = .Offset(1).Resize(lngRows, 2).Value
　　End With
　　
　　'結果の表のデータ先頭から最終行まで繰り返し
　　For i = 1 To lngRows
　　　　'重量を探索
　　　　lngColumn = ListSearch(vntData(i, 1), rngWeight)
　　　　'径を探索
　　　　lngRow = ListSearch(vntData(i, 2), rngDiameter)
　　　　'定数を配列に出力
　　　　vntData(i, 1) = rngTable.Offset(lngRow, lngColumn).Value
　　Next i
　　
　　'画面更新を停止
　　Application.ScreenUpdating = False
　　
　　'結果を出力
　　rngResult.Offset(1, 2).Resize(lngRows).Value = vntData
　　
　　strProm = "処理が完了しました"
　　　
Wayout:

　　'画面更新を再開
　　Application.ScreenUpdating = True
　　
　　Set rngTable = Nothing
　　Set rngResult = Nothing
　　Set rngDiameter = Nothing
　　Set rngWeight = Nothing

　　MsgBox strProm, vbInformation
　　　　　
End Sub

Private Function ListSearch(vntKey As Variant, rngScope As Range) As Long

　　Dim vntFound As Variant
　　
　　'Matchによる逐次探索
　　vntFound = Application.Match(vntKey, rngScope, 1)
　　'もし、エラーで無いなら
　　If Not IsError(vntFound) Then
　　　　'もし、Key値と探索位置の値が等しいなら
　　　　If vntKey = rngScope(vntFound).Value Then
　　　　　　ListSearch = vntFound
　　　　Else
　　　　　　'戻り値として、行位置を代入
　　　　　　ListSearch = vntFound + 1
　　　　End If
　　Else
　　　　ListSearch = 1
　　End If

End Function

PS:
関数でも出来そうですが、式が相当長く成りそうですね

1 hits

▼

【59200】表引きをしたい enachin 08/12/2(火) 11:22