Excel VBA – 存储和重写嵌套数据的最佳方式

我正在尝试构build一个vba工具，它从特定的单元格中分离出嵌套的数据，并为每个嵌套值重复每行中的其他字段。 例如，以下内容：

Bldg 3000 | Floor 2 | 201, 20, 203 Bldg 7010 | Floor 1 | 110, 151 

应该成为：

 Bldg 3000 | Floor 2 | 201 Bldg 3000 | Floor 2 | 202 Bldg 3000 | Floor 2 | 203 Bldg 7010 | Floor 1 | 110 Bldg 7010 | Floor 1 | 151 

我开始制作下面的程序，将所有的电子表格数据导入到一个数组中; 然而，我不知道如何处理嵌套的值，所以这只是复制电子表格到目前为止：

 Sub import() Dim ws As Worksheet Dim rng As Range Dim listing() As Variant Set ws = ThisWorkbook.Sheets("Export Worksheet") Set rng = ws.Cells.CurrentRegion spreadsheet = rng Set ws2 = ThisWorkbook.Sheets.Add ws2.Name = "test" For i = 1 To UBound(spreadsheet, 1) For j = 1 To UBound(spreadsheet, 2) Debug.Print spreadsheet(i, j) ws2.Cells(i, j) = spreadsheet(i, j) 'Need to somehow get nested data in the appropriate cells and count/store the 'unique words so that when I write to sheet, I can have another nested loop that repeats 'all row data except the target column which loops through unique words and breaks them 'out 1 x 1 Next j Next i End Sub 

所以我试图融合一个获得独特单词的函数。 它之前工作，我把数组存储的唯一单词作为二维，以便我可以存储行号以及每个唯一的单词（在我们上面的例子中，我会有3行的行号为1，他们相应的值将是201,202和203.那么我会有2个行号为2的条目，唯一的值是110和151）。

我的尝试是在下面，当我尝试redim保留multidimensional array时，我收到一个错误。 我相信这不是最好的方法，任何指导将不胜感激。

 Dim words() As Variant Dim strng As String Dim myRng As Range, r As Range ReDim words(0, 2) Function getWords_new(st As String, address As String, row As Long) 'Dim words() As Variant 'ReDim words(0, 2) 'ReDim words(0) word_length = Len(st) Start = 1 If word_length = 0 Then words(UBound(words, 1), 1) = row words(UBound(words, 1), 2) = "NULL" Else: For i = 1 To word_length If Mid(st, i, 1) = "," Then finish = i Gap = finish - Start If Gap > 0 Then word = Mid(st, Start, Gap) lim = UBound(words, 1) If lim > 0 Then 'ReDim Preserve words(1 To lim + 1, 1 To UBound(words, 2)) 'from: https://stackoverflow.com/questions/25095182/redim-preserve-with-multidimensional-array-in-excel-vba y = UBound(words, 2) ReDim Preserve words(lim + 1, y) words(lim, 2) = word Else: ReDim Preserve words(lim + 1, UBound(words, 2)) words(0, 2) = word End If Start = finish + 1 End If ElseIf i = word_length Then word = Mid(st, Start, word_length) lim = UBound(words, 1) If lim > 0 Then ReDim Preserve words(lim + 1, UBound(words, 2)) words(lim, 2) = word Else: words(0, 2) = word End If Start = finish + 1 End If Next i End If word_count = UBound(words, 1) 'If word_count > 0 Then ' 'Debug.Print address & " - Word count is: " & word_count Debug.Print "Words are: " For i = 0 To UBound(words, 1) For j = 0 To UBound(words, 2) ' Set ws = ThisWorkbook.Sheets("Stats") ' lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ' ws.Cells(lr + 1, 1) = address ' ws.Cells(lr + 1, 2) = words(i) ' ws.Cells(lr + 1, 3) = word_count Debug.Print words(i, j) Next j ' Next i 'End If End Function 

Answer 1

如果从Sheet1开始：

并运行这个短的macros：

 Sub reprg() Dim N As Long, K As Long, s1 As Worksheet, s2 As Worksheet Dim i As Long, j As Long Set s1 = Sheets("Sheet1") Set s2 = Sheets("Sheet2") K = 1 N = s1.Cells(Rows.Count, "A").End(xlUp).Row For i = 1 To N v1 = s1.Cells(i, 1) v2 = s1.Cells(i, 2) ary = Split(s1.Cells(i, 3), ", ") For Each a In ary s2.Cells(K, 1) = v1 s2.Cells(K, 2) = v2 s2.Cells(K, 3) = a K = K + 1 Next a Next i End Sub 

你将在Sheet2得到这个：

只需进行必要的更改以使用表名和列分配。

Answer 2

这可能不是做这件事的最好方法，但这是我所要做的

 Option Explicit Dim xlCell As Range Dim xlOutput As Range Dim S1 As String Sub SplitData() Set xlOutput = ActiveCell.Offset(0, 5) For Each xlCell In Selection S1 = xlCell.Offset(0, 2).Value Do Until InStr(1, S1, ",", vbTextCompare) < 1 With xlOutput .Value = xlCell.Value .Offset(0, 1).Value = xlCell.Offset(0, 1).Value .Offset(0, 2).Value = Mid(S1, 1, InStr(1, S1, ",", vbTextCompare) - 1) End With S1 = Trim(Mid(S1, InStr(1, S1, ",", vbTextCompare) + 1, Len(S1))) Set xlOutput = xlOutput.Offset(1, 0) Loop With xlOutput .Value = xlCell.Value .Offset(0, 1).Value = xlCell.Offset(0, 1).Value .Offset(0, 2).Value = S1 End With Set xlOutput = xlOutput.Offset(1, 0) Next xlCell End Sub 

然后，只需select第一列数据中的单元格并运行代码。 如果你想自动select它们，只需稍微调整一下代码即可完成

Answer 3

试试这个（略显过于简单）的代码：

 Sub SplitToSeperateRows() r = 1 For i = 1 To 2 stringToSplit = Sheets("Sheet1").Cells(i, "C") stringAsArray = Split(stringToSplit, ",") For j = 0 To UBound(stringAsArray) With Sheets("Sheet2") .Cells(r, "A") = Sheets("Sheet1").Cells(i, "A") .Cells(r, "B") = Sheets("Sheet1").Cells(i, "B") .Cells(r, "C") = stringAsArray(j) r = r + 1 End With Next j Next i End Sub