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

Question

I am using the following code to chop up a column of comma-separated lists and to return each entry in a new row:

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

While this code works perfectly, it has a fatal flaw in that any double-commas in the cells of column C will result in blank cells pushed to the new rows in column G.

Does anyone know how to edit the code so that it does not create new rows with empty cells in column G, but skips them and enters the next rows in their places as if the superfluous commas were never included in column C at all?

Answer 1

Just test for the string length of strArr as the first operation inside the For Each strArr In tempArr loop.

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

You could loop on the occurence of double comma to clean up the input as opposed to fixing the output, here is a working example:

Text in 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

You would do this just before splitting

If you want it as a function (would be better in your case) do this:

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

Then replace this in your code:

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

With this:

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

Answer 3

I have a little sample that solves blanks everywhere

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

Everything will be displayed in the immediate window (Press Ctrl + G to show it)

The result will look like this:

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