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

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

所以今天我在单行列AD：

   A B C D
约翰| 史密斯| 弗吉尼亚| 苹果，香蕉，葡萄，芒果

而且我要：

   A B C D
约翰| 史密斯| 弗吉尼亚| 苹果  
约翰| 史密斯| 弗吉尼亚| 香蕉  
约翰| 史密斯| 弗吉尼亚| 葡萄  
约翰| 史密斯| 弗吉尼亚| 芒果  

我需要macros“足够聪明”，只为CSV单元格中的条目数创build重复行。 所以，在我的例子中，我有4个水果的名字。 如果我有17个水果名称，我想要17行，每个水果的单个实例。 如果有两个相同的水果名称，没关系 – 我可以住两个相同的水果名称重复的行。

build议如何做到这一点？ 我试图parsing文本列，但不知道macros编程足够的这样做。

Answer 1

对于踢，这里是去重复

将数据从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, "$1") 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 

Answer 2

不适用于积分。

由于我有一些时间在我手上，我想演示其他人在说什么。 不过，我会再添加一点。 不过要注意的是，@ brettdj的代码比这个要好得多，但是至less这样做比较简单，如果完全没有装备来解决10万行（ 我亲自留给你 ）。

逻辑：

1. 我们使用分隔符作为分隔符。 我们将结果存储到一个数组中。
2. 我们调用一个字典并使用它来存储唯一的值。 我们也修剪数组中的string。
3. 然后，我们使用非常简单的动作来复制您的行，等于现在存储在我们的字典中的独特水果的数量。 这将给我们足够的空间来放下我们的新成果。
4. 我们将字典内容转换为resize的原始位置。

码：

 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 

build立：

结果：

我的方法的概念其实很简单。 如果不是使用上面的更好的答案，我将这样做的方式是给你的数据传递一个范围到这个子集，你有多less相关的范围。 基本上，我会从另外一个小组打电话给我。

这个代码的好处是它很容易检查，debugging，修改和操作。 不利的一面是，它会比很多的行慢，它可能是最奇怪的方式的错误倾向，并且很难维护与大量的条件。

希望这可以帮助你。 🙂