| |
こんな物を必要としているのかな？
Option Explicit
Public Sub Sample()
'処理列数
Const clngColCount As Long = 3
Dim i As Long
Dim dicIndex As Object
Dim rngResult As Range
Dim vntRisult As Variant
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'出力先のセル位置を指定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
Application.ScreenUpdating = False
'データの有る先頭セル位置を指定
With Worksheets("Sheet1").Cells(1, "A")
'処理列数分繰り返し
For i = 0 To clngColCount - 1
'処理結果を取得
vntRisult = Frequency(.Offset(, i), dicIndex)
'結果を出力
rngResult.Offset(, i).Resize(UBound(vntRisult, 1)).Value = vntRisult
Next i
End With
'出力先の参照を破棄
Set rngResult = Nothing
'dicIndexを破棄（Dictionaryオブジェクト）
Set dicIndex = Nothing
Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Function Frequency(rngList As Range, _
dicIndex As Object) As Variant
Dim i As Long
Dim vntData As Variant
Dim vntItems As Variant
Dim lngKeys() As Long
Dim lngIndex() As Long
Dim lngRow As Long
'指定のセルを基準とする
With rngList
'データ数を取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データを配列に取得
vntData = .Resize(lngRow).Value
End With
With dicIndex
'Dictionaryオブジェクトを初期化
.RemoveAll
'データの先頭から最終まで繰り返し
For i = 1 To UBound(vntData, 1)
'dicIndexにKeyデータが存在するなら
If .Exists(vntData(i, 1)) Then
'項目に、カウントを加算
.Item(vntData(i, 1)) = .Item(vntData(i, 1)) + 1
Else
'dicIndexにKeyデータと、初期値を登録
.Add vntData(i, 1), 1
End If
Next i
'データ用配列を破棄
Erase vntData
'dicIndexからKeyデータを結果用配列に取り出す
vntItems = .Keys
'Index用配列、頻度用配列を確保
ReDim lngKeys(0 To UBound(vntItems, 1))
ReDim lngIndex(0 To UBound(vntItems, 1))
'頻度用配列に頻度を記入
For i = 0 To UBound(vntItems, 1)
lngKeys(i) = .Item(vntItems(i))
lngIndex(i) = i
Next i
End With
'配列をソート
ShellSortNum lngKeys, lngIndex()
'データを出力用に並べ替え
ReDim vntData(1 To UBound(lngIndex, 1) + 1, 1 To 1)
For i = 0 To UBound(lngIndex, 1)
vntData(i + 1, 1) = vntItems(lngIndex(i))
Next i
'結果を戻り値として返す
Frequency = vntData
End Function
Private Sub ShellSortNum(lngKeys() As Long, _
lngIndex() As Long)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim lngTmpIdx As Long
Dim lngTop As Long
Dim lngEnd As Long
lngTop = LBound(lngKeys, 1)
lngEnd = UBound(lngKeys, 1)
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap <= 0
For i = lngGap + lngTop To lngEnd
lngTmpIdx = lngIndex(i)
For j = i To lngGap + lngTop Step -lngGap
If lngKeys(lngIndex(j - lngGap)) _
>= lngKeys(lngTmpIdx) Then
Exit For
End If
lngIndex(j) = lngIndex(j - lngGap)
Next j
lngIndex(j) = lngTmpIdx
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
