| |
Hirofumi さん、ありがとうございます。
>こんなので出来そうですが
>マスタ表が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:
>関数でも出来そうですが、式が相当長く成りそうですね
まず、動かしてみます。
私にはかなり高度なコードで理解できるかが不安ですが、コメントを頼りに
流れを追ってみます。
分からない点があれば、また質問させてください。
よろしくお願いします。
|
|
enachin
- 08/12/3(水) 21:00 -
