如何拆分文本单元格并将其转置为列并再次拆分？答案

【问题标题】：How to split a cell of text and transpose it into column and split it again?如何拆分文本单元格并将其转置为列并再次拆分？
【发布时间】：2020-01-24 14:33:55
【问题描述】：

我搜索了很多帖子、论坛、教程，我尝试将其中的一些结合起来，但没有什么真正适合我。现在我写了一些代码，按照逻辑我从其他编程语言中学习它应该可以工作，但是我缺少几个步骤。

假设我有这样的字符串 Test User <TUser@my-domain.pl>; Test User2 <TUser2@my-domain.pl>; Test User3 <TUser3@my-domain.pl>; Test User4 <TUser4@my-domain.pl>;

我将它粘贴到单元格中，比如说A1。我的目标是为每个较小的字符串留下 Test User 或 TUser。

这样做可以实现我的目标：

点击Text as columns -> Delimited -> Other ;，现在每个字符串都在单独的列中
复制整个A行并用转置（旋转）粘贴，所以每个字符串都在单独的行中
现在最简单的方法是使用文本作为列，通过< 分隔符。所以我只剩下Name Surname 在一个牢房里，在另一个牢房里休息

我想通过点击按钮来实现。

到目前为止我的代码：

Sub GetName()

Dim WordList As String
Dim ArrayOfWords
Dim i, i2 As Integer

'Define my word list, based on cell
WordList = Cells(1, 1)

'Use SPLIT function to convert the string to an array
ArrayOfWords = Split(WordList, "<")

'Iterate through array, and put each string into new row cell
i = 2
i2 = 1
Do While (ThereIsNoMoreText)'That I cannot figure out

Cells(2, i).Value = ArrayOfWords(i2)

i = i + 1
i2 = i2 + 1

Loop

End Sub

提前感谢您的帮助，我希望我说清楚:)

【问题讨论】：

标签： excel vba

【解决方案1】：

有趣的小选择：

Sub Test()

With CreateObject("VBScript.RegExp")
    .Global = True
    .Pattern = "(?:<.*?>)"
    arr = Split(.Replace([A1], ""), ";")
End With

With Cells(1, 2).Resize(UBound(arr))
    .Value = Application.Transpose(arr)
    .Value = Application.Trim(.Value)
End With

End Sub

显然，请务必为 Cells 创建明确的工作表引用。

【讨论】：

巫术！不错。
谢谢@CLR，但是它并没有像你那样溢出地址，但是OP提到“我的目标是留下测试用户..”所以想了想做一些正则表达式 fun =)
恭喜获得金牌。当之无愧。

【解决方案2】：

你需要先用分号分割。

将以下内容分开以获得您需要的字符串：

userlist = Split(Cells(1, 1).Value, ";")
i = 1
For Each user In userlist
    i = i + 1
    splituser = Split(user, "<")
    Cells(i, 1) = splituser(0)
    Cells(i, 2) = Mid(splituser(1), 1, Len(splituser(1)) - 1)
Next

【讨论】：

【解决方案3】：

除了其他答案中显示的方法（尤其是@JvdV 非常令人印象深刻的方法）之外，您还可以尝试一下。

此方法不使用 For…Next

Sub Users_Email_Split()
Dim aData As Variant
    With ThisWorkbook.Worksheets("TEST")
        aData = .Cells(1).Value
        aData = Left(aData, -2 + Len(aData))
        aData = Replace(aData, " <", """,""")
        aData = Replace(aData, ">; ", """;""")
        aData = "{""" & aData & """}"
        aData = Application.Evaluate(aData)
        .Cells(2, 2).Resize(UBound(aData), UBound(aData, 2)).Value = aData
    End With
    End Sub

编辑
如果 string 预计会超过 Evaluate Function 的 255 个字符限制，那么您可以使用此方法（最多 2086 个字符）。

此方法a创建一个User Defined Name，将数组字符串作为公式，然后将名称应用为FormulaArray，最后设置范围的值。

Sub Users_Email_Split_Plus255()
Dim aData As Variant
Dim lR As Long, lC As Long

    With ThisWorkbook.Worksheets("TEST")

        aData = .Cells(11, 1).Value
        aData = Left(aData, -2 + Len(aData))
        aData = Replace(aData, " <", """,""")
        aData = Replace(aData, ">; ", """;""")
        aData = "={""" & aData & """}"

        lR = 1 + UBound(Split(aData, ";"))
        lC = 1 + UBound(Split(Split(aData, ";")(0), ","))

        With .Cells(12, 2).Resize(lR, lC)

            .Worksheet.Names.Add Name:="_FmlX", RefersTo:=aData
            .FormulaArray = "=_FmlX"
            .Value = .Value

    End With: End With

    End Sub

【讨论】：

对 evaluate =) 的 255 个字符限制非常谨慎

【解决方案4】：

你必须稍微修改一下构造

Dim i As Long
Dim FirstPart As String, SecondPart As String
Dim ArrayOfWords
ArrayOfWords = Split(Cells(1, 1).Value, ";")
For i = LBound(ArrayOfWords) To UBound(ArrayOfWords)
    If InStr(1, ArrayOfWords(i), "<") > 0 Then
        FirstPart = Left(ArrayOfWords(i), InStr(1, ArrayOfWords(i), "<") - 1)
        SecondPart = Mid(ArrayOfWords(i), Len(FirstPart) + 1, Len(ArrayOfWords(i)))
        Debug.Print FirstPart & "--" & SecondPart
    End If
Next i

【讨论】：