Excel：拆分；将单元格值分成列，然后在连续的行中移动答案

【问题标题】：Excel: Split ; separated cell values into columns and then shift in consecutive rowsExcel：拆分；将单元格值分成列，然后在连续的行中移动
【发布时间】：2015-07-03 10:56:18
【问题描述】：

我处于图 1 所描述的情况，其中我有一个带有参考名称的单元格和一个带有一个或多个分号分隔的电子邮件的单元格，这些电子邮件与同一参考相关联。我想拆分包含多个电子邮件的单元格，将它们连续堆叠并复制参考名称。是否可以使用 Excel 2007 中的 VBA 宏来执行此操作？我知道“分列”命令的存在，但我不知道如何自动将列移动到行中并复制参考名称。提前致谢。

【问题讨论】：

请告诉我们您尝试了什么？

标签： vba excel

【解决方案1】：

给你：

Sub SplitColumnB()
    Dim r As Range
    Set r = [B2]
    Do While r.Value <> ""
        res = Split(r.Value, " ; ")
        i = 0
        For Each resStr In res
            If i > 0 Then r.Offset(1).EntireRow.Insert xlDown
            r.Offset(IIf(i > 0, 1, 0)).Value = resStr
            r.Offset(IIf(i > 0, 1, 0), -1).Value = Right(resStr, Len(resStr) - InStr(resStr, "@"))
            i = i + 1
        Next
        Set r = r.Offset(IIf(i > 0, i, 1))
    Loop
End Sub

【讨论】：

不错的紧凑的解决方案，但有一点误解。我不想像您那样复制 @ 之后的名称，而是复制包含电子邮件的单元格之前的单元格中的值。我相信您可以轻松纠正解决方案！再次感谢

【解决方案2】：

试试下面的代码。将所有 Sheet1 实例替换为您的工作表名称。

Sub test()

    Dim Ref As String
    Dim Eid As String
    Dim RefR()
    Dim EidR()

    Rcnt = Sheets("Sheet1").Range("A65000").End(xlUp).Row
    K = 0
    L = 0

    For i = 2 To Rcnt
        Ref = Sheets("Sheet1").Range("A" & i).Value
        Temp = Split(Sheets("Sheet1").Range("B" & i).Value, ";")
        K = K + 1
        ReDim Preserve RefR(1 To K)
        RefR(K) = Ref

        For j = LBound(Temp) To UBound(Temp)
            If L <= UBound(Temp) Then
                ReDim Preserve EidR(Rcnt, L)
                L = UBound(Temp)
            End If
            EidR(K, j) = Temp(j)
        Next j
    Next i

    RowValue = 2
    For i = 1 To UBound(RefR)
        For j = 0 To L

            Sheets("Sheet1").Range("A" & RowValue).Value = RefR(i)
            Sheets("Sheet1").Range("B" & RowValue).Value = Trim(EidR(i, j))
            RowValue = RowValue + 1
        Next j
    Next i

End Sub

【讨论】：