将数据从行移动到列 VBA

László Ádám 士兵

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

这是我到目前为止：

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 |

加里的学生

如果你从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 中得到这个：