Excel VBA質問箱 IV

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

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


9086 / 76732 ←次へ | 前へ→

【73212】Re:データーの整理
発言  UO3  - 12/12/1(土) 1:12 -

引用なし
パスワード
   ▼ブーチー さん:

バグあればご容赦。

Sub Sample()
  Dim dic1 As Object
  Dim dic2 As Object
  Dim dic3 As Object
  Dim c As Range
  Dim dKey As Variant
  Dim x As Long
  Dim cnt1 As Long
  Dim cnt2 As Long
  
  Application.ScreenUpdating = False
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set dic3 = CreateObject("Scripting.Dictionary")
  
  With Sheets("Sheet1")      '元シート
  
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      dKey = c.Value & vbTab & c.Offset(, 1).Value
      If Not dic1.exists(dKey) Then _
        Set dic1(dKey) = CreateObject("Scripting.Dictionary")
      dic1(dKey)(dic1(dKey).Count) = c.Resize(, 4).Value
      dic3(dKey) = True
    Next
    
    For Each c In .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
      dKey = c.Value & vbTab & c.Offset(, 1).Value
      If Not dic2.exists(dKey) Then _
        Set dic2(dKey) = CreateObject("Scripting.Dictionary")
      dic2(dKey)(dic2(dKey).Count) = c.Resize(, 6).Value
      dic3(dKey) = True
    Next
    
  End With
  
  With Sheets("Sheet2")      '転記シート
    .Cells.ClearContents
    .Rows(1).Value = Sheets("Sheet1").Rows(1).Value   'タイトル行
    x = 2    'データ転記開始行
    For Each dKey In dic3
      cnt1 = 0
      cnt2 = 0
      If dic1.exists(dKey) Then
        .Range("A" & x).Resize(dic1(dKey).Count, 4).Value = _
          WorksheetFunction.Transpose( _
          WorksheetFunction.Transpose(dic1(dKey).items))
        cnt1 = dic1(dKey).Count
      End If
      If dic2.exists(dKey) Then
        .Range("F" & x).Resize(dic2(dKey).Count, 6).Value = _
          WorksheetFunction.Transpose( _
          WorksheetFunction.Transpose(dic2(dKey).items))
        cnt2 = dic2(dKey).Count
      End If
        
      x = x + WorksheetFunction.Max(cnt1, cnt2)
    Next
    .Select
  End With

  Application.ScreenUpdating = True
  MsgBox "転記終了しました"
  
End Sub

1 hits

【73211】データーの整理 ブーチー 12/11/30(金) 22:05 質問
【73212】Re:データーの整理 UO3 12/12/1(土) 1:12 発言
【73217】Re:データーの整理 ブーチー 12/12/1(土) 7:14 質問
【73218】Re:データーの整理 UO3 12/12/1(土) 8:13 発言
【73219】Re:データーの整理 ブーチー 12/12/1(土) 9:33 お礼

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