Excel VBA質問箱 IV

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

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


15025 / 76738 ←次へ | 前へ→

【67198】Re:dictionary オブジェクトについて
発言  Hirofumi  - 10/11/15(月) 11:35 -

引用なし
パスワード
   Dictionaryの使い方が違うのでは?

Option Explicit

Public Sub Test_1()
  
  Dim MyD As Object
  Dim MyVal As Variant, MyVal2 As Variant
  Dim MyDate As Date
  Dim i As Long
  
  Set MyD = CreateObject("scripting.dictionary")
  
  With Sheets("シート1")
    '2行目〜最終行まで繰り返し
    For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      'KeyとしてA列の値を取得
      MyVal = .Cells(i, "A").Value '品番
      '日付を取得
      MyDate = .Cells(i, "C").Value
      'Dictionaryに登録が無かったら
      If Not MyD.Exists(MyVal) Then
        '品番をKeyとして.code、日付を登録
        MyD.Add MyVal, Array(.Cells(i, "B").Value, MyDate)
      Else
        MyVal2 = MyD(MyVal)
        '登録している日付より現在の日付が先なら
        If MyVal2(1) > MyDate Then
          'Dictionaryの日付を入れ替える
          MyVal2(1) = MyDate
          '再登録
          MyD(MyVal) = MyVal2
        End If
      End If
    Next i
  End With
  
  With Sheets("シート2")
    'List先頭〜最終まで繰り返し
    For i = 4 To .Range("A" & Rows.Count).End(xlUp).Row
      'KeyとしてA列の値を取得
      MyVal = .Cells(i, "A").Value
      'Dictionaryに登録が在ったら
      If MyD.Exists(MyVal) Then
        .Cells(i, "B").Value = MyD(MyVal)(0) 'code
        .Cells(i, "C").Value = MyD(MyVal)(1) '日付
      End If
    Next i
  End With

End Sub

リソースを無視すればもう少し速く成るかも?

Public Sub Test_2()
  
  Dim MyD As Object
  Dim MyVal() As Variant, MyVal2() As Variant
  Dim i As Long
  Dim lngRowEnd As Long
  
  Set MyD = CreateObject("scripting.dictionary")
  
  With Sheets("シート1")
    '最終行取得
    lngRowEnd = .Range("A" & Rows.Count).End(xlUp).Row
    'A、B、C列を配列として取得
    MyVal = .Range(.Cells(2, "A"), .Cells(lngRowEnd, "C")).Value
    '2行目〜最終行まで繰り返し
    For i = 1 To UBound(MyVal, 1)
      'Dictionaryに品番登録が無かったら
      If Not MyD.Exists(MyVal(i, 1)) Then
        '品番をKeyとして.code、日付を登録
        MyD.Add MyVal(i, 1), i
      Else
        '登録している日付より現在の日付が先なら
        If MyVal(MyD(MyVal(i, 1)), 1) > MyVal(i, 3) Then
          'Dictionaryの行位置を入れ替える
          MyD(MyVal(i, 1)) = i
        End If
      End If
    Next i
  End With
  
  With Sheets("シート2")
    '最終行取得
    lngRowEnd = .Range("A" & Rows.Count).End(xlUp).Row
    'A、B、C列を配列として取得
    MyVal2 = .Range(.Cells(4, "A"), .Cells(lngRowEnd, "C")).Value
    'List先頭〜最終まで繰り返し
    For i = 1 To UBound(MyVal2, 1)
      'Dictionaryに登録が在ったら
      If MyD.Exists(MyVal2(i, 1)) Then
        MyVal2(i, 2) = MyVal(MyD(MyVal2(i, 1)), 2) 'code
        MyVal2(i, 3) = MyVal(MyD(MyVal2(i, 1)), 3) '日付
      End If
    Next i
    '結果を出力
    With .Range(.Cells(4, "A"), .Cells(lngRowEnd, "C"))
      .ClearContents
      .Value = MyVal2
    End With
  End With

End Sub
0 hits

【67160】dictionary オブジェクトについて Tacchi 10/11/12(金) 15:03 質問
【67161】Re:dictionary オブジェクトについて kanabun 10/11/12(金) 16:12 発言
【67194】Re:dictionary オブジェクトについて Tacchi 10/11/15(月) 8:44 質問
【67198】Re:dictionary オブジェクトについて Hirofumi 10/11/15(月) 11:35 発言
【67199】Re:dictionary オブジェクトについて Hirofumi 10/11/15(月) 11:50 発言
【67202】Re:dictionary オブジェクトについて Tacchi 10/11/15(月) 13:31 お礼

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