VBA解析2D分隔字符串到Excel中的範圍內

Question

我有一個二維字符串由行分隔，每行內由值分隔。

所以這是一個以逗號分隔的字符串，每行末尾有一個EOL標記。例如：

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

如果創建一個循環分裂（）由[EOL]然後內部的另一個循環分裂（）通過將各值的每一行「」，然後在一個時間到一個寫每個值的一個單元格在工作表中它永遠需要，所以我正在尋找一個更有效的解決方案。

是否可以將字符串解析爲二維數組/變體，然後將整個事件一次寫入指定範圍？

Answer 1

一種方法是首先在內存中組裝一個數組，然後在一行代碼中傳輸它。第一個函數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 

Answer 2

我們可以做@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