將數據從行移動到列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 得到此：

此代碼不刪除原始數據。您可能需要更新此以容納標題等。