Excel 宏或 VBA 脚本将 CSV 单元格数据转换为行

Excel macro or VBA script to convert CSV cell data into rows

提问by user1724444

I have a spreadsheet (over 100,000 rows) with 10 columns of data. Two of the columns have comma separate value entries. I need a macro (or series of macros) or VBA script that can automatically duplicate the existing rows of data yet only have a single entry for each such comma separated value entry.

我有一个包含 10 列数据的电子表格（超过 100,000 行）。其中两列具有逗号分隔的值条目。我需要一个宏（或一系列宏）或 VBA 脚本，它可以自动复制现有的数据行，但每个这样的逗号分隔值条目只有一个条目。

So today I have in a single row, columns A-D:

所以今天我在一行中，列 AD：

  A      B        C                       D
John | Smith | Virginia | Apples, Bananas, Grapes, Mangoes

And I want:

而且我要：

  A      B        C         D
John | Smith | Virginia | Apples  
John | Smith | Virginia | Bananas  
John | Smith | Virginia | Grapes  
John | Smith | Virginia | Mangoes  

I need the macro to be "smart enough" to only create duplicate rows for the number of entries in the CSV cell. So, in my example, I had 4 fruit names. If I had 17 fruit names, I'd want 17 rows, each with a single instance of each fruit. If there are two identical fruit names, that's okay - I can live with two duplicate rows of the same exact fruit name.

我需要宏“足够聪明”，以便仅为 CSV 单元格中的条目数创建重复的行。因此，在我的示例中，我有 4 个水果名称。如果我有 17 个水果名称，我想要 17 行，每行每个水果都有一个实例。如果有两个相同的水果名称，那没关系 - 我可以忍受两行完全相同的水果名称。

Advice on how to accomplish this? I'm tried to parse text to columns but don't know enough about macro programming to do this.

关于如何实现这一点的建议？我试图将文本解析为列，但对宏编程知之甚少。

回答by brettdj

For kicks, here it is with the de-duping

对于踢球，这里是重复数据删除

Converts data from A:Dto E:H

将数据从 转换A:D为E:H

Sub SliceNDice()
    Dim objRegex As Object
    Dim X
    Dim Y
    Dim lngRow As Long
    Dim lngCnt As Long
    Dim tempArr() As String
    Dim strArr
    Set objRegex = CreateObject("vbscript.regexp")
    objRegex.Pattern = "^\s+(.+?)$"
     'Define the range to be analysed
    X = Range([a1], Cells(Rows.Count, "d").End(xlUp)).Value2
    ReDim Y(1 To 4, 1 To 1000)
    For lngRow = 1 To UBound(X, 1)
         'Split each string by ","
        tempArr = Split(X(lngRow, 4), ",")
        For Each strArr In tempArr
            lngCnt = lngCnt + 1
             'Add another 1000 records to resorted array every 1000 records
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 4, 1 To lngCnt + 1000)
            Y(1, lngCnt) = X(lngRow, 1)
            Y(2, lngCnt) = X(lngRow, 2)
            Y(3, lngCnt) = X(lngRow, 3)
            Y(4, lngCnt) = objRegex.Replace(strArr, "")
        Next
    Next lngRow
     'Dump the re-ordered range to columns E:H
    [e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)
    ActiveSheet.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlNo
End Sub

回答by Jerome Montino

Not for points.

不是为了积分。

Since I have some time on my hands, I want to demo what the others above are saying. However, I'll add a little bit more. Note however, that @brettdj's code is much better than this, but at least this is quite simpler, if altogether not that equipped to solve 100,000 rows (that, I personally leave to you).

由于我有一些时间，我想演示上面其他人所说的内容。不过，我会再补充一点。但是请注意，@brettdj 的代码比这要好得多，但至少这相当简单，如果完全没有能力解决 100,000 行（我个人留给你）。

The logic:

逻辑：

1. We split the string using ,as a delimiter. We store the result into an array.
2. We invoke a dictionary and use it to store unique values only. We trim the strings in the array as well.
3. We then use very simple movements to copy your row a number of times equal to the number of unique fruits now stored in our dictionary. This will give us enough space to post down our new list of fruits.
4. We transpose the dictionary contents into the resized original location.

1. 我们使用,分隔符分割字符串。我们将结果存储到一个数组中。
2. 我们调用字典并仅使用它来存储唯一值。我们也修剪数组中的字符串。
3. 然后，我们使用非常简单的动作来复制您的行，次数等于现在存储在我们字典中的独特水果的数量。这将为我们提供足够的空间来发布我们的新水果清单。
4. 我们将字典内容转置到调整大小的原始位置。

Code:

代码：

Sub FruitNinja()

    Dim FrootWhere As Range, Dict As Object
    Dim Frooty As String, Froots() As String

    Set FrootWhere = Range("D1")

    Frooty = FrootWhere.Value
    Froots = Split(Frooty, ",")

    Set Dict = CreateObject("Scripting.Dictionary")

    For i = LBound(Froots) To UBound(Froots)
        If Not Dict.Exists(Froots(i)) Then
            Dict.Add Trim(Froots(i)), Empty
        End If
    Next i

    FrootWhere.EntireRow.Copy
    Cells(FrootWhere.Row + 1, 1).Resize(Dict.Count - 1, 1).EntireRow.Insert
    FrootWhere.Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys)

    Set FrootWhere = Nothing
    Set Dict = Nothing
    Application.CutCopyMode = False

End Sub

Set-up:

设置：

Result:

结果：

The concept of my approach is actually very simple. The way I'll do it given your data, if not using the better answer above, is to pass in a range to this sub, for how many relevant ranges you have. Basically, I'll be calling this from another sub.

我的方法的概念实际上非常简单。如果不使用上面更好的答案，我将根据您的数据执行此操作的方法是将一个范围传递给此子程序，以了解您拥有多少相关范围。基本上，我会从另一个潜艇调用它。

The upside of this code is that it's pretty easy to check, debug, modify, and manipulate. The downside to this is that it'll be slow versus a large number of rows, it can be error prone in the weirdest of ways, and that it's hard to maintain versus a large number of conditions.

这段代码的优点是检查、调试、修改和操作非常容易。这样做的缺点是与大量行相比它会很慢，它可能以最奇怪的方式容易出错，并且与大量条件相比难以维护。

Hope this helps you. :)

希望这对你有帮助。:)