Excel VBA質問箱 IV

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

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


56180 / 76732 ←次へ | 前へ→

【25310】Re:重複データを一行にまとめる
回答  Hirofumi  - 05/5/27(金) 19:49 -

引用なし
パスワード
   'データが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

1 hits

【25308】重複データを一行にまとめる さくら 05/5/27(金) 14:41 質問
【25310】Re:重複データを一行にまとめる Hirofumi 05/5/27(金) 19:49 回答
【25312】Re:重複データを一行にまとめる ponpon 05/5/27(金) 20:31 発言
【25314】Re:重複データを一行にまとめる だるま 05/5/27(金) 21:52 回答
【25369】Re:重複データを一行にまとめる さくら 05/5/30(月) 9:21 お礼

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