Dictionaryオブジェクトを利用する:Excel VBA入門 |
スポンサードリンク | |
Sub dic0_1() Dim myDic As Object, myKey Dim c, myVal Dim i As Long Set myDic = CreateObject("Scripting.Dictionary") '---myDicにKeyとItemを格納する For i = 2 To 7 myDic.Add Cells(i, 1).Value, Cells(i, 2).Value Next i '---Itemを取り出す For i = 2 To 7 Cells(i, 5).Value = myDic.Item(Cells(i, 4).Value) Next i Set myDic = Nothing End Sub |
Sub dic0_1a() Dim myDic As Object, myKey Dim c, myVal Dim i As Long Set myDic = CreateObject("Scripting.Dictionary") '---myDicにKeyとItemを格納する For i = 2 To 7 myDic(Cells(i, 1).Value) = Cells(i, 2).Value Next i '---Itemを取り出す For i = 2 To 7 Cells(i, 5).Value = myDic.Item(Cells(i, 4).Value) Next i Set myDic = Nothing End Sub |
Sub dic0_12() Dim myDic As Object, myKey Dim c, myVal Dim i As Long Set myDic = CreateObject("Scripting.Dictionary") '---myDicにKeyとItemを格納する For i = 2 To 7 If Not myDic.exists(Cells(i, 1).Value) Then myDic.Add Cells(i, 1).Value, Cells(i, 2).Value End If Next i '---Itemを取り出す For i = 2 To 7 Cells(i, 5).Value = myDic.Item(Cells(i, 4).Value) Next i Set myDic = Nothing End Sub |
Sub rei21_1() Dim myDic As Object, myKey Dim c, myVal Dim i As Long Set myDic = CreateObject("Scripting.Dictionary") ' ---(1)元データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value ' ---(2)myDicへデータを格納 For Each c In myVal If Not c = Empty Then If Not myDic.Exists(c) Then myDic.Add c, "" End If End If Next ' ---(3)Keyの書き出し myKey = myDic.Keys For i = 0 To myDic.Count - 1 Cells(i + 2, 4) = myKey(i) Next i Set myDic = Nothing End Sub |
' ---(3)Keyの書き出し myKey = myDic.keys Range("D2").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey) |
Sub rei21_2() Dim myDic As Object, myKey, myItem Dim myVal Dim i As Long Set myDic = CreateObject("Scripting.Dictionary") Range("D2", Range("E" & Rows.Count).End(xlUp)).ClearContents Range("D1:E1").Value = Range("A1:B1").Value ' ---元データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value ' ---myDicへデータを格納 For i = 1 To UBound(myVal, 1) If Not myVal(i, 1) = Empty Then If Not myDic.exists(myVal(i, 1)) Then '---新たなkeyの時はkeyとitemを追加します myDic.Add myVal(i, 1), myVal(i, 2) Else '---すでに存在しているkeyの時はitemを加算します myDic(myVal(i, 1)) = myDic(myVal(i, 1)) + myVal(i, 2) End If End If Next ' ---Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) Cells(i + 2, 4).Value = myKey(i) Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing End Sub |
' ---Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items Range("D2").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey) Range("E2").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myItem) |
Sub rei21_3() Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3 Dim i As Long Range("E2", Range("G" & Rows.Count).End(xlUp)).ClearContents Range("E1:G1").Value = Range("A1:C1").Value Set myDic = CreateObject("Scripting.Dictionary") ' ---元データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value ' ---myDicへデータを格納 For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) If Not myVal2 = "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next ' ---Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") Cells(i + 2, 5).Value = myVal3(0) Cells(i + 2, 6).Value = myVal3(1) Cells(i + 2, 7).Value = myItem(i) Next Set myDic = Nothing ' ---並べ替え Range("E1", Range("G" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("E2"), Order1:=xlAscending, _ Key2:=Range("F2"), Order2:=xlAscending, _ Header:=xlGuess End Sub |
object.CompareMode = | 値 | 内容 |
vbBinaryCompare | 0 | バイナリモード 大文字小文字を区別します。 |
vbTextCompare | 1 | テキストモード 大文字小文字を区別しない |
vbDatabaseCompare | 2 | Accessの場合のみ有効 |
スポンサードリンク
PageViewCounter
Since2006/2/27