Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
空白行は無視する検索
投稿日時: 20/06/07 11:48:22
投稿者: 銀河

 おせはは様になります。
 下記に私が色々な参考本たWEBで調べたりして作成しました。
 マクロの内容は数量計算縦シートのD列をディクショナリーの項目(Key)に入れ、S列数量を(Item)に
 格納し、縦計算集計シートのD列5行目からデータを入力していくマクロですが、空白行も入ってきます。
 ディクショナリーでKeyとItemを重複なしで、空白行を無視して格納する方法のヒントを教えて下さい。
 よろしくお願いします。
 
 
Sub 数量縦集計()
    Dim myDic As New Dictionary
    Dim i As Long
    Dim vkey As Variant
     
Application.ScreenUpdating = False
   With Worksheets("数量計算縦")
        For i = 4 To Cells(Rows.count, 4).End(xlUp).Row
            If myDic.Exists(Cells(i, 4).Value) Then
                myDic(Cells(i, 4).Value) = myDic(Cells(i, 4).Value) + Cells(i, 19).Value
            Else
                myDic.Add Cells(i, 4).Value, Cells(i, 19).Value
            End If
        Next
   End With
   
  Worksheets("縦計算集計").Activate
    With Worksheets("縦計算集計")
          For i = 0 To myDic.count - 1
             Cells(i + 5, 4) = myDic.Keys(i)
             Cells(i + 5, 19) = myDic.Items(i)
         Next
    End With
     
Application.ScreenUpdating = True
End Sub

回答
投稿日時: 20/06/07 13:23:06
投稿者: simple

String変数sを追加したうえで、こんな風に書くとよいでしょう。

    With Worksheets("数量計算縦")
        For i = 4 To .Cells(Rows.count, 4).End(xlUp).Row
            s = .Cells(i, 4).Value
            If s <> "" Then
                If myDic.Exists(s) Then
                    myDic(s) = myDic(s) + .Cells(i, 19).Value
                Else
                    myDic.Add s, .Cells(i, 19).Value
                End If
            End If
        Next
    End With

実は、これは以下のように書いても同じ結果が得られます。
    With Worksheets("数量計算縦")
        For i = 4 To .Cells(Rows.count, 4).End(xlUp).Row
            s = .Cells(i, 4).Value
            If s <> "" Then
                myDic(s) = myDic(s) + .Cells(i, 19).Value
            End If
        Next
    End With

なお、書き込む際のセルにもシートの特定が必要です。

回答
投稿日時: 20/06/07 13:33:57
投稿者: simple

なお、結果を書き込む際には、量が多い場合に1セルずつ書き込むと効率が悪いので、
こんな風に書くと一括書き込みができます。ご参考まで。

    With Worksheets("縦計算集計")
        .Cells(5, 4).Resize(myDic.Count, 1) = Application.Transpose(myDic.Keys)
        .Cells(5, 19).Resize(myDic.Count, 1) = Application.Transpose(myDic.Items)
    End With

投稿日時: 20/06/08 11:35:46
投稿者: 銀河

 simple 様
ご回答ありがとうございます。
サンプルまで教えていただき、ありがとうございました。
空白セルははじかれて、希望通りの動作を確認しました。
また、わからない時は教えてください。