Excel VBA質問箱 IV

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

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


22850 / 76732 ←次へ | 前へ→

【59257】Re:表引きをしたい
発言  enachin  - 08/12/3(水) 21:00 -

引用なし
パスワード
   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:
>関数でも出来そうですが、式が相当長く成りそうですね
まず、動かしてみます。
私にはかなり高度なコードで理解できるかが不安ですが、コメントを頼りに
流れを追ってみます。
分からない点があれば、また質問させてください。
よろしくお願いします。
2 hits

【59200】表引きをしたい enachin 08/12/2(火) 11:22 質問
【59202】Re:表引きをしたい ひげくま 08/12/2(火) 12:08 発言
【59204】Re:表引きをしたい enachin 08/12/2(火) 12:35 発言
【59205】Re:表引きをしたい Jaka 08/12/2(火) 13:04 発言
【59207】Re:表引きをしたい enachin 08/12/2(火) 13:18 発言
【59210】Re:表引きをしたい Jaka 08/12/2(火) 15:03 発言
【59216】Re:表引きをしたい enachin 08/12/2(火) 16:48 発言
【59239】Re:表引きをしたい ひげくま 08/12/3(水) 9:18 回答
【59241】Re:表引きをしたい enachin 08/12/3(水) 11:11 発言
【59242】Re:表引きをしたい ひげくま 08/12/3(水) 12:05 発言
【59248】Re:表引きをしたい enachin 08/12/3(水) 17:47 発言
【59249】Re:表引きをしたい トト 08/12/3(水) 19:04 発言
【59255】Re:表引きをしたい トト 08/12/3(水) 20:29 発言
【59254】Re:表引きをしたい Hirofumi 08/12/3(水) 20:24 回答
【59257】Re:表引きをしたい enachin 08/12/3(水) 21:00 発言
【59267】Re:表引きをしたい ひげくま 08/12/4(木) 8:52 回答
【59280】Re:表引きをしたい enachin 08/12/4(木) 17:08 お礼

22850 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free