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

Question

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

我的尝试如下，当我尝试重新调整保留多维数组时收到错误消息。我确信这不是最好的方法，我们将不胜感激。

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开始：

并运行这个简短的宏：

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

然后只需选择第一列数据中的单元格并运行代码。如果您想自动选择它们，只需对代码稍作调整即可完成

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