| |
元のデータ配列は、基底0の配列で、日付が0列、時間が1列の有る物としています
結果の配列は、基底0の配列で、日付が0列、時間が1列、出現回数が2列と成ります
尚、一時的に配列が、3倍に膨れるので其の点が心配
Option Explicit
Public Sub Sample()
Dim vntData As Variant
Dim vntItem As Variant
Dim vntResult As Variant
Dim i As Long
Dim dicIndex As Object
Dim lngRow As Long
Dim vntKey As Variant
'テスト用データを作成
'vntDataの配列は基底0の配列で、
'vntData(lngRow, 0)に日付、vntData(lngRow, 1)に時間が入る物としています
'詰まり、ActiveSheetのA列に日付、B列に時間が文字列で入力されている物とします
With ActiveSheet.Cells(1, "A")
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
ReDim vntData(lngRow, 1)
For i = 0 To lngRow
vntData(i, 0) = .Offset(i).Value
vntData(i, 1) = .Offset(i, 1).Value
Next i
End With
'ここから本題
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'dicIndexに就いて
With dicIndex
'データ配列の最後まで繰り返し
For i = 0 To UBound(vntData, 1)
'Keyを作成（Tabを挟んで、日付と時間を結合）
vntKey = vntData(i, 0) & vbTab & vntData(i, 1)
'もし、dicIndexにKeyが存在するなら
If .Exists(vntKey) Then
'項目に1つ加算
.Item(vntKey) = .Item(vntKey) + 1
Else
'Keyと初期値1を登録
.Add vntKey, 1
End If
Next i
'元データを消去
Erase vntData
'dicIndexから、全てのKeyを取得
vntKey = .Keys
'結果用配列を確保
ReDim vntResult(.Count - 1, 2)
'Key全てに就いて
For i = 0 To .Count - 1
'Keyから日付を分離して、結果配列の0列に代入
vntResult(i, 0) = Left(vntKey(i), _
InStr(1, vntKey(i), vbTab, vbBinaryCompare) - 1)
'Keyから時間を分離して、結果配列の1列に代入
vntResult(i, 1) = Mid(vntKey(i), _
InStr(1, vntKey(i), vbTab, vbBinaryCompare) + 1)
'dicIndexからKeyに対する項目（出現回数）を取得し、
'結果配列の2列に代入
vntResult(i, 2) = .Item(vntKey(i))
Next i
End With
'一時的に取得した配列を消去
Erase vntKey
'dicIndexを破棄
Set dicIndex = Nothing
'結果を確認の為、シートに出力
With ActiveSheet.Cells(1, "D")
.Resize(UBound(vntResult, 1) + 1, 3) = vntResult
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
