Splitting a value that is delimitted

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

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 2

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")

Answer 3

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