Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


60483 / 76732 ←次へ | 前へ→

【20887】Re:データの頻出順にリストを作りたいのですが
回答  Hirofumi  - 04/12/23(木) 15:54 -

引用なし
パスワード
   こんな物を必要としているのかな?

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
0 hits

【20864】データの頻出順にリストを作りたいのですが あいりあり 04/12/23(木) 12:47 質問
【20865】Re:データの頻出順にリストを作りたいので... IROC 04/12/23(木) 12:55 回答
【20867】Re:データの頻出順にリストを作りたいので... あいりあり 04/12/23(木) 13:33 質問
【20871】Re:データの頻出順にリストを作りたいので... ちゃっぴ 04/12/23(木) 13:51 回答
【20877】Re:データの頻出順にリストを作りたいので... IROC 04/12/23(木) 14:17 回答
【20892】Re:データの頻出順にリストを作りたいので... あいりあり 04/12/23(木) 18:15 お礼
【20893】Re:データの頻出順にリストを作りたいので... あいりあり 04/12/23(木) 18:22 お礼
【20887】Re:データの頻出順にリストを作りたいので... Hirofumi 04/12/23(木) 15:54 回答
【20891】Re:データの頻出順にリストを作りたいので... あいりあり 04/12/23(木) 18:14 お礼
【20894】Re:データの頻出順にリストを作りたいので... Hirofumi 04/12/23(木) 18:42 回答
【20890】Re:データの頻出順にリストを作りたいので... [名前なし] 04/12/23(木) 17:31 回答
【20895】Re:データの頻出順にリストを作りたいので... [名前なし] 04/12/23(木) 19:44 発言
【20896】Re:データの頻出順にリストを作りたいので... [名前なし] 04/12/23(木) 19:48 発言

60483 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free