Excel VBA質問箱 IV

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

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


1600 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【73211】データーの整理
質問  ブーチー  - 12/11/30(金) 22:05 -

引用なし
パスワード
   データを整理したいのですが、どうすれば実現出来るのか教えてください。

   A  B  C  D  E  F  G  H  I  J  K
1  グループ1       グループ2
2  1 花  い う    1  机  い い か  す
3  1 机  う す    2  机  う か す  す
4  2 砂  み み    3  花
5  2 机 
6  3 花
7  3 花

上のようなデータがあります。
A列とF列の数字は1〜12まであり、月を表しています。
各月の中でグループ1とグループ2のデータを花や机で横に並べて整理したいです。
整理後は以下のようになります。


   A  B  C  D  E  F  G  H  I  J  K
1  1行目は項目です
2  1 花  い う    
3  1 机  う す    1  机  い い か  す
4  2 砂  み み    
5  2 机         2  机  う か す  す
6  3 花         3  花
7  3 花

【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

【73217】Re:データーの整理
質問  ブーチー  - 12/12/1(土) 7:14 -

引用なし
パスワード
   ▼UO3 さん ありがとうございます。

実行したら以下のようになり、F列が1月、3月、2月と順番がずれてしまいました。
   A  B  C  D  E  F  G  H  I  J  K
1  1行目は項目です
2  1 花  い う    
3  1 机  う す     1  机  い い か  す
4  2 砂  み み    
5  2 机          
6  3 花          3  花
7  3 花
8                2  机  う か す  す

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

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

こちらでは、ちゃんと整列しています。
たとえば、月の数字、大文字、小文字も一致してますか?

もしグループ2の 机だけが小文字であとは大文字なら、
そちらの結果になりますが、すべてが同じであれば、問題ないはずです。

【73219】Re:データーの整理
お礼  ブーチー  - 12/12/1(土) 9:33 -

引用なし
パスワード
   ▼UO3 さん 何度もありがとうございます。
半角、全角が混ざってなければ、うまくいきました。

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