行から列にデータを移動するVBA

Question

電子メールアドレスに割り当てられたセッション名があるレポートがあります。レポートに2つの行を生成した電子メールアドレスに2つのセッション名が割り当てられている場合は、各電子メールアドレスに対して行が1つしかなく、セッション名が互いに隣接する列に格納されているレポートを作成します。

これは私がこれまで持っているものです。

Sub Session() 
i = Sheets(1).Range("a1048576").End(xlUp).Row 
l = Sheets(2).Range("a1048576").End(xlUp).Row 

For k = 2 To i 
    For x = 2 To l 
    EmailReg = Sheets(1).Range("c" & k).Value 
    EmailAtt = Sheets(2).Range("c" & x).Value 

    c = Sheets(1).Range("b" & k).Value 
    d = Sheets(2).Range("A" & x).Value 


     If EmailReg = EmailAtt Then 
      Sheets(1).Range("D" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("E" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("f" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("g" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("h" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("i" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 
     If EmailReg = EmailAtt Then 
      Sheets(1).Range("j" & k).Value = Sheets(2).Range("D" & x).Value 
      Sheets(2).Range("c" & x).Value = "" 
     End If 

    Next 
Next 
End Sub 

それが唯一の異なる列に最後のセッション名を置きますので、必要に応じて、それが働いていません。

入力は次のようになります。

___ A ____|___ B ____ 
1 | email1 | session1 
2 | email1 | session2 
3 | email1 | session3 
4 | email2 | session1 
5 | email2 | session2 

出力は次のようになります。

___ A ____|___ B ____|___ C ____|___ D ____ 
1 | email1 | session1 | session2 | session3 
2 | email2 | session1 | session2 | 

Answer 1

あなたはSheet2のでこれを起動する場合：

このマクロを実行します。

Sub ReArrange() 
    Dim sh1 As Worksheet, sh2 As Worksheet 
    Dim i As Long, j As Long, k As Long 

    Set sh1 = Sheets(1) 
    Set sh2 = Sheets(2) 
    sh1.Cells(1, 1) = sh2.Cells(1, 1) 
    sh1.Cells(1, 2) = sh2.Cells(1, 2) 
    k = 3 
    j = 1 

    For i = 2 To Rows.Count 
     If sh2.Cells(i, 1).Value = "" Then Exit Sub 
     If sh2.Cells(i, 1) = sh2.Cells(i - 1, 1) Then 
      sh1.Cells(j, k) = sh2.Cells(i, 2) 
      k = k + 1 
     Else 
      j = j + 1 
      sh1.Cells(j, 1) = sh2.Cells(i, 1) 
      sh1.Cells(j, 2) = sh2.Cells(i, 2) 
      k = 3 
     End If 
    Next i 
End Sub 

あなたはSheet1のでこれを取得します：

をこのコードは、は、元のデータを消去しません。ヘッダーなどに対応するには、これを更新する必要があります。