| |
'データがSheet1のA1から有るとします
'結果をSheet2のA1から出力します
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim lngMax As Long
Dim vntData As Variant
Dim vntResult As Variant
Dim dicIndex As Object
Dim strProm As String
'データListの先頭A1を指定
With Worksheets("Sheet1").Cells(1, "A")
'A列の行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'A列、B列を配列に取得
vntData = .Resize(lngRows, 2).Value
End With
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
'データ配列の最終行まで繰り返し
For i = 1 To lngRows
'DictionaryにA列の値が有った場合
If .Exists(vntData(i, 1)) Then
'Dictionaryの項目を結果配列に取得
vntResult = .Item(vntData(i, 1))
'結果配列のIndexの上限+1を取得
lngMax = UBound(vntResult) + 1
'結果配列を拡張
ReDim Preserve vntResult(lngMax)
'結果配列にB列の値を追加
vntResult(lngMax) = vntData(i, 2)
'結果配列をDictionaryの項目に再登録
.Item(vntData(i, 1)) = vntResult
Else
'結果配列を確保
ReDim vntResult(1)
'結果配列にA列、B列の値を代入
vntResult(0) = vntData(i, 1)
vntResult(1) = vntData(i, 2)
'結果配列をDictionaryに登録
.Add vntData(i, 1), vntResult
End If
Next i
'DictionaryのKeyを全て配列に取得
vntData = .Keys
End With
' Application.ScreenUpdating = False
'出力シートのA1を指定
With Worksheets("Sheet2").Cells(1, "A")
'Key（A列の値）全てに就いて繰り返し
For i = 0 To UBound(vntData)
'Dictionaryの項目を結果配列に取得
vntResult = dicIndex.Item(vntData(i))
'結果配列のIndexの上限+1を取得
lngMax = UBound(vntResult) + 1
'結果配列をシートに出力
.Offset(i).Resize(, lngMax).Value = vntResult
Next i
End With
' Application.ScreenUpdating = True
'Dictionaryオブジェクトのインスタンスを破棄
Set dicIndex = Nothing
strProm = "処理が完了しました"
Wayout:
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/5/27(金) 19:49 -
