Excel VBA質問箱 IV

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

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


2568 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【67160】dictionary オブジェクトについて
質問  Tacchi  - 10/11/12(金) 15:03 -

引用なし
パスワード
   どうしても、分からず悩んでおります
どうか、アドバイスを頂きたいです

A列に品番
B列にCode
C列に日付
が入っているシートがあります
8000件ほどあります

例えば、A列に同じ品番が複数行存在しており、
同じ品番の中で一番日付が最短のものを格納したいと思っていますが、
どうも、うまくいきません

今、下記のようにコードを記述しています

Dim MyD As Object
Dim MyVal, MyVal2

Set MyD = CreateObject("scripting.dictionary")

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
   MyVal = Cells(i, "A").Value & "|" & Cells(i, "B").Value
   If Not MyD.exists(MyVal) Then
    MyD.Add MyVal, Cells(i, "C").Value 
   Else
    ’ココで、もし、同じ品番があったら、すでに格納されてる
    ' 日付と比べて、最短のほうを格納する
    ' といった方法をとりたいです
   End If
Nex i
   
どうかよろしくお願いします

 

【67161】Re:dictionary オブジェクトについて
発言  kanabun  - 10/11/12(金) 16:12 -

引用なし
パスワード
   ▼Tacchi さん:
こんにちは。

>同じ品番の中で一番日付が最短のものを格納したいと思っていますが、
>どうも、うまくいきません

未検証ですが、以下では?

>Dim MyD As Object
Dim MyVal As String, MyVal2
Dim myDate As Date
>
>Set MyD = CreateObject("scripting.dictionary")
>
>For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
>   MyVal = Cells(i, "A").Value & "|" & Cells(i, "B").Value
   myDate = Cells(i, "C").Value
>   If Not MyD.exists(MyVal) Then
>    MyD.Add MyVal, myDate 
>   Else
>    ’ココで、もし、同じ品番があったら、すでに格納されてる
>    ' 日付と比べて、最短のほうを格納する
>    ' といった方法をとりたいです
     If MyD(MyVal) < myDate Then MyD(MyVal) = myDate

>   End If
>Nex i

【67194】Re:dictionary オブジェクトについて
質問  Tacchi  - 10/11/15(月) 8:44 -

引用なし
パスワード
   ▼kanabun さん:

ありがとうございます
アドバイスどおりやってみたところうまくいきました

でも、一つ問題が・・・あって、すごく時間がかかるということです。
dictionaryで格納したものを、
今度は、違うシートの2行目から最終行まで、チェックし、
格納した品番だったら、C列に、先ほどの格納した日付を入力するというマクロを組んでいるのですが、すごく時間がかかってしまいます
dictionaryオブジェクト意外に、何か、違う方法はないものか?と
いろいろネットを見ているのですが、なかなか見つかりません
もし、いい方法があれば・・・?と思っているのですが・・・
もし、あれば伝授していただきたいです

シート1
A列;品番
B列;CODE
C列;日付

シート2
A列;品番
B列;CODE
C列;最短日付 
※【シート2】に、品番がマッチしたらC列に最短日付を入れる

今は下記のような記述になってます

Dim MyD As Object
Dim MyVal, MyVal2
Dim MyDate As Date

Dim MyKey, MyItem

Set MyD = CreateObject("scripting.dictionary")

Sheets("シート1").Activate
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
   MyVal = Cells(i, "A").Value & "|" & Cells(i, "B").Value '品番とCODE
   MyDate = Cells(i, "C").Value
   If Not MyD.exists(MyVal) Then
    MyD.Add MyVal, Cells(i, "C").Value '日付
   Else
    If MyD(MyVal) > MyDate Then MyD(MyVal) = MyDate
   End If
Next i

MyKey = MyD.keys
MyItem = MyD.items

Sheets("シート2").Activate
For i = 0 To UBound(MyKey)
  MyVal2 = Split(MyKey(i), "|")
  For z = 4 To Range("A" & Rows.Count).End(xlUp).Row
     If Cells(z, "A").Value = MyVal2(0) Then '同じ品番だったら
       Cells(z, "B").Value = MyVal2(1) 'code
       Cells(z, "C").Value = MyItem(i) '日付
     End If
  Next z
Next i


>▼Tacchi さん:
>こんにちは。
>
>>同じ品番の中で一番日付が最短のものを格納したいと思っていますが、
>>どうも、うまくいきません
>
>未検証ですが、以下では?
>
>>Dim MyD As Object
> Dim MyVal As String, MyVal2
> Dim myDate As Date
>>
>>Set MyD = CreateObject("scripting.dictionary")
>>
>>For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
>>   MyVal = Cells(i, "A").Value & "|" & Cells(i, "B").Value
>   myDate = Cells(i, "C").Value
>>   If Not MyD.exists(MyVal) Then
>>    MyD.Add MyVal, myDate 
>>   Else
>>    ’ココで、もし、同じ品番があったら、すでに格納されてる
>>    ' 日付と比べて、最短のほうを格納する
>>    ' といった方法をとりたいです
>     If MyD(MyVal) < myDate Then MyD(MyVal) = myDate
>
>>   End If
>>Nex i

【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

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

引用なし
パスワード
   以下を書き忘れました
追加して下さい

  End With

  Set MyD = Nothing '★追加
  
End Sub

【67202】Re:dictionary オブジェクトについて
お礼  Tacchi  - 10/11/15(月) 13:31 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございました

始めの記述のほうを試してみたところ、
何倍も早く処理ができるようになりました

本当に助かりました

2つめの記述のほうも、解読中です
試してみます

もうすこし、dictionaryについて勉強してみます

ありがとうございました

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