Question

我获得了一个大型数据转储，它从一些其他程序导出到excel，我需要编写一个宏来清理。

它是一个包含目录组中组和成员的大文件。问题是它将所有成员转储到一个单元格中，用分号分隔。

我认为需要做的是创建一个宏，它首先执行文本到列的操作，将数据分成列，然后以某种方式插入足够的行来将列转换为行。

我很难解释，所以我会提供一个例子......我希望这有助于说明我的问题。

我想要这个：

+---+--------+---------------------+
|   |   A    |          B          |
+---+--------+---------------------+
| 1 | Group1 | Name1; Name2; Name3 |
| 2 | Group2 | Name1               |
| 3 | Group3 | Name1; Name2        |
+---+--------+---------------------+`

看起来像这样：

+---+--------+-------+
|   |   A    |   B   |
+---+--------+-------+
| 1 | Group1 | Name1 |
| 2 | Group1 | Name2 |
| 3 | Group1 | Name3 |
| 4 | Group2 | Name1 |
| 5 | Group3 | Name1 |
| 6 | Group3 | Name2 |
+---+--------+-------+

这些＆＃34;名称＆＃34;单元格中可以包含1到500个名称。

非常感谢任何帮助。即使只是某个地方开始......我不知所措。

编辑虽然我的问题类似于标记的问题，但存在需要不同代码的差异。另一个人的问题涉及将数据从第一列解析为新行并复制后续列。我的问题恰恰相反。也许如果我在VBA上做得更好，我可以修改其他代码来匹配我的问题。

对那些发表讽刺意见和/或贬低信息的人：意识到我甚至很难表达我的问题，并且在发布之前尝试搜索答案。你的帮助是没有根据的，也没有建设性，我建议为你的想法寻找一个不同的场所（试试Reddit，那里有很多巨魔可以随身携带）。我希望这对那些真正想要帮助的人来说是个好地方。

Answer 1

Sub Spl()

Dim P1 As Range, T2(), a As Integer
Set P1 = Sheets(1).UsedRange 'Adapt to your data sheet and range
T1 = P1
a = 1

For i = 1 To UBound(T1)
    If i = 1 Then
        ReDim Preserve T2(1 To 3, 1 To a)
        T2(1, a) = T1(i, 1)
        T2(2, a) = T1(i, 2)
        T2(3, a) = T1(i, 3)
        a = a + 1
    Else
        Spl1 = Split(T1(i, 3), ";")
        For j = 0 To UBound(Spl1)
            ReDim Preserve T2(1 To 3, 1 To a)
            T2(1, a) = T1(i, 1)
            T2(2, a) = T1(i, 2)
            T2(3, a) = Trim(Spl1(j))
            a = a + 1
        Next j
    End If
Next i

Sheets(2).Range("A1").Resize(UBound(T2, 2), UBound(T2, 1)) = Application.Transpose(T2) 'Adapt to your destination

End Sub

Answer 2

以下是我用来完成这项工作的代码。基本上它会删除名字，将其粘贴到活动单元格中，插入新行并粘贴剩余的名称和组，偏移一行，然后循环返回。我不得不添加一个循环来从分隔的名称中删除前导空格。

    Sub Separate_Names()

    Dim nameStr As String 'Holds the value for the members of the group
    Dim groupStr As String 'Holds the value of the group name
    Dim delimitStr As String 'The character used to seperate names

    Dim cutAtInt As Integer 'Holds the value of where to cut name
    Dim spaceInt As Integer 'Value for first space

    delimitStr = ";" 'The character that the names are delimited by

    Range("B2").Activate 'Activate the first cell to change
    cutAtInt = InStr(nameStr, delimitStr)

    'Loop Begins
    Do Until IsEmpty(ActiveCell.Value)


    nameStr = ActiveCell
    cutAtInt = InStr(nameStr, delimitStr)

    If cutAtInt > 0 Then
        groupStr = ActiveCell.Offset(0, -1).Value
        'Loop to trim leading spaces
        spaceInt = InStr(nameStr, " ")
        Do Until spaceInt <> 1
            nameStr = Right(nameStr, Len(nameStr) - 1)
            spaceInt = InStr(nameStr, " ")
        Loop
        cutAtInt = InStr(nameStr, delimitStr)
        ActiveCell.Value = Left(nameStr, cutAtInt - 1)
        nameStr = Right(nameStr, Len(nameStr) - (cutAtInt + 1))
        ActiveCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
        ActiveCell.Offset(1, 0).Value = nameStr
        ActiveCell.Offset(1, -1).Value = groupStr
    Else
        spaceInt = InStr(nameStr, " ")
        Do Until spaceInt <> 1
            nameStr = Right(nameStr, Len(nameStr) - 1)
            spaceInt = InStr(nameStr, " ")
        Loop
        ActiveCell.Value = nameStr
    End If

    ActiveCell.Offset(1, 0).Activate

    Loop

    End Sub

如果我能做出任何改进，请告诉我。

文本到列然后转置

2 个答案: