将数据从行移动到列VBA

Question

我有一个报告，其中有会话名称分配给电子邮件地址。如果有两个会话名称分配给在报告中生成两行的电子邮件地址，我想创建一个报告，其中每个电子邮件地址只有一行，而会话名称存储在彼此相邻的列中。

这是我到目前为止有：

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 得到此：

此代码不删除原始数据。您可能需要更新此以容纳标题等。