Excel VBA-存储和重写嵌套数据的最佳方法

我正在尝试构建一个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

所以我试图解释一个函数，它可以得到唯一的单词。它在我制作数组之前就已经工作了，数组将唯一的单词存储为二维，这样我就可以存储行号以及每个uniqe单词（在上面的示例中，我有3个条目的行号为1，它们对应的值分别为201、202和203。然后我有2个条目的行号为2，唯一值分别为110和151）

下面是我的尝试，我在尝试重新定义多维数组时收到一个错误。我确信这不是最好的方法，请提供任何指导

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

---

这可能不是最好的方法，但我会这么做

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

选项显式
暗淡的xlCell As范围
作为范围的输出
将S1变暗为字符串
子拆分数据（）
设置xlOutput=ActiveCell.Offset（0,5）
对于选择中的每个单元格
S1=xlCell.Offset（0,2）.Value
直到InStr（1，S1，，，，vbTextCompare）小于1
带XLP输出
.Value=xlCell.Value
.Offset（0，1）.Value=xlCell.Offset（0，1）.Value
.偏移量（0，2）.值=中间值（S1，1，仪表（1，S1，“，”，vbTextCompare）-1）
以
S1=微调（中间（S1，仪表（1，S1，“，”，vbTextCompare）+1，透镜（S1）））
设置xlOutput=xlOutput.Offset（1,0）
环
带XLP输出
.Value=xlCell.Value
.Offset（0，1）.Value=xlCell.Offset（0，1）.Value
.偏移量（0，2）.值=S1
以
设置xlOutput=xlOutput.Offset（1,0）
下一个xlCell
端接头

---

然后只需选择第一列数据中的单元格并运行代码。如果您想自动选择它们，也可以通过对代码进行小调整来完成，如果您在

Sheet1

中开始此操作：

然后运行以下短宏：

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

您将在

表单2中看到此信息：


只需进行必要的更改即可使用工作表名称和列分配。
尝试以下代码（稍微简化）：

您只能
ReDim
数组的最后一个维度，因此如果确实需要对这两个维度执行此操作，则应使用两个单独的数组。使用拆分（）函数。它可以将逗号分隔的字符串转换成数组。再加上一些逻辑，你应该能够实现你的目标…@UGP，谢谢你的建议。对不起，但我不完全理解。因为我需要将原始行ID与存储的单词相关联，我如何将这两个单独的数组关联起来？@Noceo，谢谢。我应该能够使用split来更有效地获取单词。我仍然需要弄清楚如何处理嵌套数据的存储，为每个维度使用一个数组。
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