[英]Excel 2010 VBA - Split String by Comma, Skip Blank Results
我正在使用以下代碼來分割一列以逗號分隔的列表並在新行中返回每個條目:
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 列中一樣?
只需測試 strArr 的字符串長度作為 For Each strArr In tempArr 循環中的第一個操作。
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
您可以循環出現雙逗號來清理輸入而不是修復輸出,這是一個工作示例:
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)), ",")
我有一個小樣本可以解決任何地方的空白
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.