将二维分隔符字符串解析成范围。

Question

我是一名有用的助手，可以为您翻译文本。

我有一个二维字符串，其中每行由值分隔。

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

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

如果我创建一个循环来通过[EOL]拆分每行，然后在其中再创建一个循环来通过','拆分每个值，然后逐个将每个值写入工作表中的单元格，这样做需要很长时间，因此我正在寻找更有效的解决方案。

是否可以将字符串解析为2D数组/变量，然后一次性将整个内容写入命名区域？

- doncooper

---

一个范围内的多个单元格在技术上也是一个二维数组，因此您可以使用 UBound() 和 Resize() 直接将数组输入到范围中，而无需循环。 - SierraOscar

Answer 1

我们可以按照评论中@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

- Axel Richter

Answer 2

一种方法是先在内存中组装一个数组，然后在一行代码中传输它。第一个函数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

这是一个可以处理不同长度行的版本：

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

为了获取一些时间信息，我编写了一个子程序来生成一个字符串，该字符串分为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

当我运行它时，输出如下：

String has length 99990
Finished in 0.09375 seconds

- John Coleman