VBA将2D分隔的字符串解析为excel中的范围

I have a two dimensional string delimited by line and within each line delimited by value.

我有一个二维字符串，由行分隔，并在每个由value分隔的行中。

So it's a comma delimited string with an EOL marker at the end of each line. Example:

所以它是一个逗号分隔的字符串，每行末尾都有一个EOL标记。例：

val1, val2, val3 ... valn [EOL]
val1, val2, val3 ... valn [EOL]
...
val1, val2, val3 ... valn [EOL]

If I create a loop to split() each line by [EOL] then another loop inside that to split() each value by ',' and then write each value one at a time to a cell in the worksheet it takes forever so I'm looking for a more efficient solution.

如果我通过[EOL]创建一个循环来split（）每一行，然后在其中的另一个循环将每个值拆分（），然后将每个值一次写入工作表中的一个单元格，这是永远的，所以我正在寻找更有效的解决方案。

Is it possible to parse the string into a 2D array/variant and then write the whole thing at once to a named range?

是否可以将字符串解析为2D数组/变体，然后将整个事物一次写入命名范围？

2 个解决方案

#1

We can do what @Macro Man said in the comments. It will be easy if all rows contain the same count of comma delimited values. If not, it will be more complicated. But nevertheless solvable.

我们可以做@Macro Man在评论中所说的话。如果所有行都包含相同的逗号分隔值，则很容易。如果没有，它会更复杂。但仍然可以解决。

Option Base 0

Sub test()

 sString = "val1, val2, val3 ... valn" & Chr(10) & "val1, val2 ... valn" & Chr(10) & "val1, val2, val3, val4 ... valn" & Chr(10) & "val1" & Chr(10)

 Dim aDataArray() As Variant
 Dim lLinesCount As Long
 Dim lValuesCount As Long
 Dim lMaxValuesCount As Long

 aLines = Split(sString, Chr(10))
 lLinesCount = UBound(aLines)
 ReDim aDataArray(0 To lLinesCount, 0)

 For i = LBound(aLines) To UBound(aLines)
  aValues = Split(aLines(i), ",")
  lValuesCount = UBound(aValues)
  If lValuesCount > lMaxValuesCount Then lMaxValuesCount = lValuesCount
  ReDim Preserve aDataArray(0 To lLinesCount, 0 To lMaxValuesCount)

  For j = LBound(aValues) To UBound(aValues)
   aDataArray(i, j) = aValues(j)
  Next
 Next

 With ActiveSheet
  .Range("B2").Resize(lLinesCount + 1, lMaxValuesCount + 1).Value = aDataArray
 End With

End Sub

#2

One approach is to first assemble an array in memory and then transfer it in one line of code. The first function, MultiSplit, assumes that each row contains the same number of elements. The second function, MultiSplit2, drops that assumption (at the cost of more processing). Use whichever version matches your situation.

一种方法是首先在内存中组装一个数组，然后在一行代码中传输它。第一个函数MultiSplit假定每行包含相同数量的元素。第二个函数MultiSplit2放弃了这个假设（以更多处理为代价）。使用符合您情况的版本。

Function MultiSplit(s As String, d1 As String, d2 As String) As Variant
    'd1 is column delimiter, d2 is row delimiter
    'returns an array

    Dim m As Long, n As Long, i As Long, j As Long
    Dim tempRows As Variant, tempRow As Variant
    Dim retA As Variant 'return array

    tempRows = Split(s, d2)
    m = UBound(tempRows)
    If Len(tempRows(m)) = 0 Then 'original string ends with a delimiter
        m = m - 1
        ReDim Preserve tempRows(m)
    End If

    tempRow = Split(tempRows(0), d1)
    n = UBound(tempRow)
    ReDim retA(1 To m + 1, 1 To n + 1) '1-based more natural for intended ranges

    For i = 1 To m + 1
        For j = 1 To n + 1
            retA(i, j) = tempRow(j - 1)
        Next j
        If i < m + 1 Then tempRow = Split(tempRows(i - 1), d1) ' next row to process
    Next i
    MultiSplit = retA
End Function

Sub test()
    Dim testString As String, A As Variant, R As Range
    testString = "a,b,c,d;e,f,g,h;i,j,k,l"

    A = MultiSplit(testString, ",", ";")
    Set R = Range(Cells(1, 1), Cells(UBound(A, 1), UBound(A, 2)))
    R.Value = A
End Sub

Here is a version that can handle rows of various lengths:

这是一个可以处理各种长度的行的版本：

Function MultiSplit2(s As String, d1 As String, d2 As String) As Variant
    'd1 is column delimiter, d2 is row delimiter
    'returns an array

    Dim m As Long, n As Long, i As Long, j As Long
    Dim tempRows As Variant, jaggedArray As Variant
    Dim retA As Variant 'return array

    tempRows = Split(s, d2)
    m = UBound(tempRows)
    If Len(tempRows(m)) = 0 Then 'original string ends with a delimiter
        m = m - 1
        ReDim Preserve tempRows(m)
    End If

    ReDim jaggedArray(0 To m)
    For i = 0 To m
        jaggedArray(i) = Split(tempRows(i), d1)
        If UBound(jaggedArray(i)) > n Then n = UBound(jaggedArray(i))
    Next i

    ReDim retA(1 To m + 1, 1 To n + 1) '1-based more natural for intended ranges

    For i = 1 To m + 1
        For j = 1 To 1 + UBound(jaggedArray(i - 1))
            retA(i, j) = jaggedArray(i - 1)(j - 1)
        Next j
    Next i
    MultiSplit2 = retA
End Function

Sub test2()
    Dim testString As String, A As Variant, R As Range
    testString = "a,b,c;d,e,f,g,h;i;j,k,l,m,n,o,p;"

    A = MultiSplit2(testString, ",", ";")
    Set R = Range(Cells(1, 1), Cells(UBound(A, 1), UBound(A, 2)))
    R.Value = A
End Sub

To get some timing information, I wrote a sub to generate a string which splits into 1000 rows and up to 100 columns:

为了得到一些定时信息，我写了一个子来生成一个字符串，该字符串分为1000行和最多100列：

Sub test3()
    Dim s As String, A As Variant, R As Range
    Dim i As Long, j As Long, start As Double
    Dim n As Long

    For i = 1 To 1000
        n = i Mod 100
        For j = 1 To n
            s = s & "a" & IIf(j < n, ",", vbCrLf)
        Next j
        DoEvents 'in case it hangs
    Next i
    Debug.Print "String has length " & Len(s)
    start = Timer
    A = MultiSplit2(s, ",", vbCrLf)
    Set R = Range(Cells(1, 1), Cells(UBound(A, 1), UBound(A, 2)))
    R.Value = A
    Debug.Print "Finished in " & Timer - start & " seconds"
End Sub

When I ran it I got the output:

当我运行它时，我得到了输出：

String has length 99990
Finished in 0.09375 seconds

#1