Question

我想知道是否有人可以帮我解决以下问题，

在Excel中的VBA中，我有下表：

Column 1|Column2|Column3|Column4|Column5|Column6
---------|---------|---------|---------|---------|---------
1.2.3.4|Apple%Car|Canada%USA|Tomatoes|Hotel|Montreal%Paris%New-York
1.3.4.6|Cat%Uniform%Dog|France|Ananas|Motel|Amsterdam%San-Diego

我想在Excel中使用VBA将其转换为下表：

 Column 1|Column 2|Column 3|Column 4|Column 5|Column 6
 :---------:|:---------:|:---------:|:---------:|:---------:|:---------:
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Montreal
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Paris
 1.2.3.4|Apple|Canada|Tomatoes|Hotel|New-York
 1.2.3.4|Apple|USA|Tomatoes|Hotel|Montreal
 1.2.3.4|Apple|USA|Tomatoes|Hotel|Paris
 1.2.3.4|Apple|USA|Tomatoes|Hotel|New-York
 1.2.3.4|Car|Canada|Tomatoes|Hotel|Montreal
 1.2.3.4|Car|Canada|Tomatoes|Hotel|Paris
 1.2.3.4|Car|Canada|Tomatoes|Hotel|New-York
 1.2.3.4|Car|USA|Tomatoes|Hotel|Montreal
 1.2.3.4|Car|USA|Tomatoes|Hotel|Paris
 1.2.3.4|Car|USA|Tomatoes|Hotel|New-York
 1.3.4.6|Cat|France|Ananas|Motel|Amsterdam
 1.3.4.6|Cat|France|Ananas|Motel|San-Diego
 1.3.4.6|Uniform|France|Ananas|Motel|Amsterdam
 1.3.4.6|Uniform|France|Ananas|Motel|San-Diego
 1.3.4.6|Dog|France|Ananas|Motel|Amsterdam
 1.3.4.6|Dog|France|Ananas|Motel|San-Diego

有谁知道如何做到这一点？

谢谢！

Answer 1

为了让我的大脑继续前进。这或多或少都是你想要的（但是还有改进的余地，因为它目前可以产生重复的行，然后在最后删除。我已经错过了一些东西但是你没有尝试过任何东西我没有＃＆＃ 39，不再费心去弄清楚这种情况究竟发生在哪里。

您还必须更改输入和输出来自ConvertToTable子区域的范围。这使用递归函数（即调用自身的函数）来填充输出

Option Explicit
Public Sub ConvertToTable()
    Dim data As Variant, tmp() As Variant
    Dim arr() As Variant
    Dim i As Long
    Dim c As Range

    With Sheet2
        data = Range(.Cells(1, 1), .Cells(2, 6)).Value2
    End With

    For i = LBound(data, 1) To UBound(data, 1)
        tmp = Application.Index(data, i, 0)
        arr = PopulateResults(tmp, "%", arr)
    Next i
    With Sheet4
        With .Range(.Cells(1, 1), .Cells(UBound(arr, 2), UBound(arr, 1)))
            .Value2 = Application.Transpose(arr)
            .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo
        End With
    End With
End Sub

Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As Variant) As Variant()
    Dim i As Long, j As Long
    Dim DelCount As Long, MaxDel As Long
    Dim tmp2 As Variant

    On Error Resume Next
    i = UBound(Results, 2) + 1
    If i = 0 Then i = 1
    On Error GoTo 0

    ReDim Preserve Results(1 To UBound(tmp), 1 To i)
    For j = 1 To UBound(tmp)
        Results(j, i) = tmp(j)
        If InStr(1, tmp(j), delimiter, vbTextCompare) Then
            DelCount = 0
            Results(j, i) = Split(tmp(j), delimiter)(DelCount)
            Do
                DelCount = DelCount + 1
                tmp2 = tmp
                tmp2(j) = Split(tmp(j), delimiter)(DelCount)
                Results = PopulateResults(tmp2, delimiter, Results)
            Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
        End If
    Next j
    PopulateResults = Results
End Function

Answer 2

非常感谢，非常感谢。抱歉延迟，我没有收到任何回复的电子邮件通知。

我玩了源代码，我有以下内容，它适用于包含短值的所有列..：

'Transform the data
Dim data As Variant, tmp() As Variant
Dim arr() As String
Dim i As Long
Dim c As Range

    With Aggregation_Source
        data = Range(Cells(1, 1), Cells(2, 8)).Value2
    End With

    For i = LBound(data, 1) To UBound(data, 1)
        tmp = Application.Index(data, i, 0)
        arr = PopulateResults(tmp, "%", arr)
    Next i

With Aggregation_Source
        With Range(Cells(1, 1), Cells(UBound(arr, 2), UBound(arr, 1)))
            .Value2 = Application.Transpose(arr)
            .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
        End With
    End With
End Sub

Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As String) As String()
    Dim i As Long, j As Long
    Dim DelCount As Long, MaxDel As Long
    Dim tmp2 As Variant

    On Error Resume Next
    i = UBound(Results, 2) + 1
    If i = 0 Then i = 1
    On Error GoTo 0

    ReDim Preserve Results(1 To UBound(tmp), 1 To i)
    For j = 1 To UBound(tmp)
        Results(j, i) = tmp(j)
        If InStr(1, tmp(j), delimiter, vbTextCompare) Then
            DelCount = 0
            Results(j, i) = Split(tmp(j), delimiter)(DelCount)
            Do
                DelCount = DelCount + 1
                tmp2 = tmp
                tmp2(j) = Split(tmp(j), delimiter)(DelCount)
                Results = PopulateResults(tmp2, delimiter, Results)
            Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString))
        End If
    Next j
    PopulateResults = Results
End Function

现在，我认为代码崩溃是因为我有一个列包含两个由％超过1000个字符分隔的长文本，我将尝试更改arr（）的类型以查看它是否有效但我想我我在代码中遗漏了一些东西。

VBA - 将多个分隔列转换为多行

2 个答案: