Excel 2010 VBA - 用逗号拆分字符串，跳过空白结果。

Question

我正在使用下面的代码将一列逗号分隔的列表砍掉，并将每个条目返回到新的行中。

Sub SliceNDice()
    '
    ' Splits the locations cells according to commas and pushes to new rows
    ' Code courtesy of brettdj (http://stackoverflow.com/questions/8560718/split-comma-separated-entries-to-new-rows)
    '
    Dim objRegex As Object
    Dim x
    Dim Y
    Dim lngRow As Long
    Dim lngCnt As Long
    Dim tempArr() As String
    Dim strArr
    Set objRegex = CreateObject("vbscript.regexp")

    objRegex.Pattern = "^\s+(.+?)$"
     'Define the range to be analysed
    x = Range([a1], Cells(Rows.Count, "c").End(xlUp)).Value2
    ReDim Y(1 To 3, 1 To 1000)
    For lngRow = 1 To UBound(x, 1)
         'Split each string by ","
        tempArr = Split(x(lngRow, 3), ",")
        For Each strArr In tempArr
            lngCnt = lngCnt + 1
             'Add another 1000 records to resorted array every 1000 records
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
            Y(1, lngCnt) = x(lngRow, 1)
            Y(2, lngCnt) = x(lngRow, 2)
            Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
        Next
    Next lngRow
     'Dump the re-ordered range to columns E:G
    [e1].Resize(lngCnt, 3).Value2 = Application.Transpose(Y)

End Sub

虽然这段代码工作得很完美，但它有一个致命的缺陷，即C列单元格中的任何双逗号都会导致空白单元格被推送到G列的新行中。

有谁知道如何编辑这段代码，使它不会在G列中创建带有空单元格的新行，而是跳过它们，并在它们的位置上输入下一行，就好像C列中根本没有多余的逗号一样？

Answer 1

只需在For Each strArr In tempArr循环内测试strArr的字符串长度作为第一个操作。

For Each strArr In tempArr
    If CBool(Len(strArr)) Then
        lngCnt = lngCnt + 1
         'Add another 1000 records to resorted array every 1000 records
        If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 3, 1 To lngCnt + 1000)
        Y(1, lngCnt) = x(lngRow, 1)
        Y(2, lngCnt) = x(lngRow, 2)
        Y(3, lngCnt) = objRegex.Replace(strArr, "$1")
    End If
Next strArr

Answer 2

你可以对双逗号的出现进行循环清理输入，而不是固定输出，这里有一个工作实例。

文本在A1中。Hello,,World,This,,Is,,,,,,,A,,Test

Sub TestString()
Dim MyString As String
MyString = Range("A1").Text
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
    MyString = Replace(MyString, ",,", ",")
Loop
MsgBox MyString
End Sub

你可以在分割之前这样做

如果你想把它作为一个函数（在你的情况下会更好），可以这样做。

Function FixDoubleComma(MyString As String)
Do Until Len(MyString) = Len(Replace(MyString, ",,", ","))
    MyString = Replace(MyString, ",,", ",")
Loop
FixDoubleComma = MyString
End Function

然后在你的代码中替换这个

tempArr = Split(x(lngRow, 3), ",")

用这个代替

tempArr = Split(FixDoubleComma(x(lngRow, 3)), ",")

Answer 3

我有个小例子可以解决到处都是空白的问题。

Sub RemoveBlanks()
    Dim mystr As String
    Dim arrWithBlanks() As String
    Dim arrNoBlanks() As String
    Dim i As Integer
    mystr = ",tom,jerry, ,,spike,," 'Blanks everywhere (beginning, middle and end)
    arrWithBlanks = Split(mystr, ",")
    ReDim arrNoBlanks(0 To 0)
    Debug.Print "Array with blanks:"
    'Loop through the array with blanks
    For i = LBound(arrWithBlanks) To UBound(arrWithBlanks)
        'Check if there is a blank (or element with spaces only)
        If Trim(arrWithBlanks(i)) = "" Then
            Debug.Print i & " (blank)"
        Else
            Debug.Print i & " " & arrWithBlanks(i)
            If arrNoBlanks(UBound(arrNoBlanks)) <> "" Then ReDim Preserve arrNoBlanks(0 To UBound(arrNoBlanks) + 1)
            arrNoBlanks(UBound(arrNoBlanks)) = arrWithBlanks(i)
        End If
    Next i
    Debug.Print "Array with NO blanks:"
    For i = LBound(arrNoBlanks) To UBound(arrNoBlanks)
        Debug.Print i & " " & arrNoBlanks(i)
    Next i
End Sub

所有的东西都会在眼前的窗口中显示出来（按下 Ctrl + G 以显示它)

结果会是这样的。

Array with blanks:  
0 (blank)
1 tom
2 jerry
3 (blank)
4 (blank)
5 spike
6 (blank)
7 (blank)
Array with NO blanks:
0 tom
1 jerry
2 spike