VBAparsing2D分隔string到Excel中的范围

我有一个二维string由行分隔，并在每行由值分隔。

所以这是一个以逗号分隔的string，在每行末尾有一个EOL标记。 例：

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

如果我用[EOL]创build一个循环来分割（）每行，然后另一个内部循环来分割（）每个值的'，'然后写每个值一次一个工作表中的单元格，它永远需要，所以我正在寻找更有效的解决scheme。

是否有可能将stringparsing为二维数组/变体，然后将整个事件写入一个命名的范围？

Answer 1

在评论中，我们可以做麦克曼说的话。 如果所有行都包含相同数量的逗号分隔值，那将很简单。 如果不是，那将更加复杂。 但仍然可以解决。

 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 

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 

为了得到一些时间信息，我写了一个sub来产生一个分成1000行和100列的string：

 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