重複しない2組のデータのリストを作成する:Excel VBA入門 |
スポンサードリンク | |
Sub myDic() Dim myDic As Object, myKey As Variant Dim c As Variant, varData As Variant '重複しない種類を抽出します Set myDic = CreateObject("Scripting.Dictionary") With Worksheets("Sheet3") varData = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value End With For Each c In varData If Not c = Empty Then If Not myDic.Exists(c) Then myDic.Add c, Null End If End If Next ’種類をシートへ書き出します myKey = myDic.Keys With Worksheets("Sheet3") .Range("G2").Resize(1, 100).ClearContents .Range("G2").Resize(1, myDic.Count) = myKey End With ' ' ' Dim i As Long, j As Long Dim varData2 As Variant ' 元データの種類と品名を配列へ読み込みます With Worksheets("Sheet3") varData2 = .Range("A2", .Range("B" & Rows.Count).End(xlUp)).Value End With '各種類ごとに重複しない品名を抽出します。 For i = LBound(myKey) To UBound(myKey) Dim myDic2 As Object, myKey2 As Variant Set myDic2 = CreateObject("Scripting.Dictionary") For j = LBound(varData2) To UBound(varData2) If varData2(j, 1) = myKey(i) Then If Not myDic2.Exists(varData2(j, 2)) Then myDic2.Add varData2(j, 2), Null End If End If Next j '品名をシートへ書き出します myKey2 = myDic2.Keys With Worksheets("Sheet3") .Range("G3").Offset(0, i).Resize(myDic2.Count) = Application.WorksheetFunction.Transpose(myKey2) End With Set myDic2 = Nothing Erase myKey2 Next i Set myDic = Nothing End Sub |
スポンサードリンク
PageViewCounter
Since2006/2/27