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
1 hits

【24267】表引きの定石をご教示下さい daihan 05/4/18(月) 9:23 質問
【24272】Re:表引きの定石をご教示下さい ウッシ 05/4/18(月) 12:06 回答
【24278】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 13:38 発言
【24280】Re:表引きの定石をご教示下さい Jaka 05/4/18(月) 13:58 発言
【24281】Re:表引きの定石をご教示下さい ウッシ 05/4/18(月) 14:26 回答
【24285】Re:表引きの定石をご教示下さい G-Luck 05/4/18(月) 17:20 発言
【24287】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 17:50 発言
【24290】Re:表引きの定石をご教示下さい G-Luck 05/4/18(月) 18:25 発言
【24293】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 19:22 お礼
【24296】Re:表引きの定石をご教示下さい ウッシ 05/4/18(月) 19:48 回答
【24298】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 22:20 発言
【24352】Re:表引きの定石をご教示下さい daihan 05/4/20(水) 9:36 発言
【24360】Re:表引きの定石をご教示下さい ウッシ 05/4/20(水) 15:27 回答
【24518】Re:表引きの定石をご教示下さい Daihan 05/4/23(土) 23:17 発言
【24520】Re:表引きの定石をご教示下さい ウッシ 05/4/24(日) 0:41 回答
【24286】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 17:32 発言
【24327】Re:表引きの定石をご教示下さい Jaka 05/4/19(火) 16:03 回答
【24354】Re:表引きの定石をご教示下さい daihan 05/4/20(水) 10:08 質問
【24297】Re:表引きの定石をご教示下さい Hirofumi 05/4/18(月) 21:48 回答
【24299】Re:表引きの定石をご教示下さい daihan 05/4/18(月) 22:26 発言
【24351】Re:表引きの定石をご教示下さい daihan 05/4/20(水) 8:58 お礼
【24372】Re:表引きの定石をご教示下さい Hirofumi 05/4/20(水) 20:22 回答
【24516】Re:表引きの定石をご教示下さい Daihan 05/4/23(土) 23:10 お礼

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