Excel VBA質問箱 IV

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

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


60057 / 76732 ←次へ | 前へ→

【21326】Re:いい案がありましたら教えてください。
回答  Hirofumi  - 05/1/18(火) 20:03 -

引用なし
パスワード
   元のデータ配列は、基底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

0 hits

【21303】いい案がありましたら教えてください。 たま 05/1/18(火) 16:48 質問
【21304】Re:いい案がありましたら教えてください。 IROC 05/1/18(火) 16:56 回答
【21306】Re:いい案がありましたら教えてください。 たま 05/1/18(火) 17:04 回答
【21308】Re:いい案がありましたら教えてください。 IROC 05/1/18(火) 17:22 回答
【21310】Re:いい案がありましたら教えてください。 たま 05/1/18(火) 17:35 回答
【21312】Re:いい案がありましたら教えてください。 IROC 05/1/18(火) 17:50 回答
【21315】Re:いい案がありましたら教えてください。 たま 05/1/18(火) 17:59 回答
【21317】Re:いい案がありましたら教えてください。 IROC 05/1/18(火) 18:17 回答
【21336】Re:いい案がありましたら教えてください。 たま 05/1/19(水) 8:41 お礼
【21326】Re:いい案がありましたら教えてください。 Hirofumi 05/1/18(火) 20:03 回答

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