Splitting a value that is delimitted - vba

Question

transactions sheet
ID1 Name Amount ID2
123 A 1 0;124;0
456 B 2 124;0;0
789 C 3 456;0;0
transactions sheet (Expected Result)
ID1 Name Amount ID2 Summary
123 A 1 0;124;0 124
456 B 2 124;0;0 456
789 C 3 456;0;0
I have tried text to columns but I am unsure on how to ignore all the 0's and only display the value if its >0 in column D. I am new to vba so would appreciate some advice on this so I can learn.
Code:
Sub SplitRange()
Dim cell As Range
Dim str As Variant 'string array
Dim r As Integer
For Each cel In ActiveSheet.UsedRange
If InStr(cell.Value, ";") > 0 Then 'split
str = Split(cell.Value, ";")
For r = LBound(str) To UBound(str)
cel.Offset(r).Value = Trim(str(r))
If r < UBound(str) Then cell.Offset(r + 1).EntireRow.Insert
Next r
End If
Next cell
End Sub

Answer 1

At first we should not loop through all used cells but only the row where these ID2 are that we need, which is a lot faster.
The easiest way would be just to remove all ;0 and 0; then only the value remains. The following will work if there is always only one real value that is not 0 e.g 0;124;0.
Public Sub FindValueRangeInColumn()
Const Col As Long = 4 'the column where the ID2 is in
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row 'find last used row in column
Dim iRow As Long
For iRow = 2 To lRow 'loop throug rows from 2 to last used row
Dim strSource As String
strSource = ws.Cells(iRow, Col) 'read value
strSource = Replace(ws.Cells(iRow, Col), ";0", "") 'remove all ;0
If Left$(strSource, 2) = "0;" Then strSource = Right$(strSource, Len(strSource) - 2) 'remove 0; from the beginnning
ws.Cells(iRow, Col + 1).Value = strSource 'write value
Next iRow
End Sub
If there can be more than 1 non-zero value like 0;124;0;222;0;0;144 then replace
ws.Cells(iRow, Col + 1).Value = strSource 'write value
with a splitting alternative …
If InStr(1, strSource, ";") > 1 Then
Dim SplitValues As Variant
SplitValues = Split(strSource, ";")
Dim iValue As Long
For iValue = LBound(SplitValues) To UBound(SplitValues)
ws.Cells(iRow, Col + 1 + iValue).Value = SplitValues(iValue) 'write value
Next iValue
Else
ws.Cells(iRow, Col + 1).Value = strSource 'write value
End If

Answer 2

Morning,
What you need here is to split the entry into an array and then check the values of the array as you loop the array:
Sub SplitString()
Dim TempArray() As String
Dim i as Integer
Dim j As Integer
For i = 1 To 10
TempArray = Split(Worksheets("Sheet1").Cells(i,4).Value,";")
For j = 0 to UBound(TempArray)
If CDbl(TempArray(j)) <> 0 Then
[Output value]
End if
Next j
Next i
End Sub
Create a more useful loop than 1 = 1 to 10 but you get the idea...
Note in the above:
- The CDbl is to ensure that the check reads it as a number and not a text string.

Answer 3

So, you want to concatenate non-0 values into a string, then put that in the next cell?
Sub SplitRange()
Dim workcell As Range
Dim str() As String 'string array
Dim r As Long 'VBA automatically stores Integers as Longs, so there is no Memory saved by not using Long
Dim output As String
output = ";" 'Start with a single delimiter
For Each workcell In Intersect(ActiveSheet.UsedRange,ActiveSheet.Columns(4)) 'Go down the cells in Column D
If InStr(workcell.Value, ";") > 0 Then 'split
str = Split(workcell.Value,";")
For r = LBound(str) To UBound(str)
If inStr(output, ";" & Trim(str(r)) & ";") < 1 Then 'If number is not already in output
output = output & Trim(str(r)) & ";" 'Add the number and ";" to the end of the string
End If
Next r
Erase str 'Tidy up array, ready to recycle
End If
Next workcell
'We now have a unique list of all items, starting/ending/delimited with ";"
output = Replace(output,";0;",";") 'Remove the item ";0;" if it exists
If Len(output) > 2 Then 'output contains at least 1 non-zero number
output= Mid(output,2,len(output)-2) 'Remove ";" from the start and end
str = Split(output,";") 'Split the list of unique values into an array
For r = lbound(str) To ubound(str)
ActiveSheet.Cells(r+2-lbound(str),5).Value = str(r) 'List the values in column 5, starting from row 2
Next r
Erase str 'Tidy up array
End If
End Sub
To remove "0"s from a single row as an Excel formula, try this:
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE("|;" & A1 & ";|", ";0;",";"),";|",""),"|;","")
From the inside-out:
SUBSTITUTE("|;" & A1 & ";|", ";0;",";") Sandwich our values in wrappers ("|;0;240;0;|") and replace any ";0;" with ";" ("|;240;|")
.
SUBSTITUTE(PREV,";|","") Remove ";|" ("|;240")
.
SUBSTITUTE(PREV,"|;","") Remove "|;" ("240")