Search code examples
excelvbainfinite-loop

VBA code goes into an infinite loop and will then fill-down the entire infinite column

I have been dealing with customer bill of materials that contains references with numbers that are separated by a dash, rather than the full sequence of references spelled out, e.g. C1-4 instead of C1, C2, C3, C4 or C1 C2 C3 C4

Some customers will use a comma to separate references, some only a space, sometimes there is a mix of the two. Sometimes customers leave a blank line between sections of references, which also complicates things. Empty cells should remain empty in the output. Here is an example:

   CR161-169

 (blank line)
 
   R2, R5, 7-11

   R103-7
   
   R26 R28-30 R42, R45-46, R62-65, R70-71, R92-102, R113-114
   
   R31-35 R40-41 R56-61 R72-79 R86-91

 (blank line)
   
   LED1-4, 6-8

I'm trying to make a VBA macro that will generate the full set of references automatically for the selected portion of the references column, and generate that full set of references in the column next to it.

So the output I'm looking for is:

CR161 CR162 CR163 CR164 CR165 CR166 CR167 CR168 CR169
(Blank line)
R2 R5 R7 R8 R9 R10 R11
R103 R104 R105 R106 R107
etc.

I have run into a couple of (I think related) problems.

  1. In the output, any blank lines are not staying blank, they are filled with the references from the cell above it.
  2. If I select the entire column, it goes into an infinite loop and fills down the entire column to infinity below the end of the references with the references from the last cell. I tried to stop it from doing that with an End If, but I clearly didn't do that right.

Another issue driving me bonkers is the case of R2, R5, 7-11, it outputs as R2 R5 7 8 9 10 11 instead of with the R prefix. If that can't be fixed, it's acceptable for what I'm doing, but having the prefix in front of each number is preferable.

I am not great with VBA, but I got the below code running without throwing any errors when I only run the macro on a selection of references, aside from the problems I mentioned above. Any help would be immensely appreciated.

Sub ParseCell()
' Set the input range where your values are
Dim inputRange As Range, outputCell As Range, inputArea As Range
Dim inputCell As Variant
Dim startNum As Long, endNum As Long
Dim i As Long
Dim resList  As String
Debug.Print "Selection_change"

Set inputRange = Selection ' Use the selected range as input

' Set the output range where you want the split references
Set outputCell = inputRange.Offset(0, 1).Cells(1) ' Output in the column next to the input

    ' Loop through each area in the input range
    resList = ""
    For Each inputArea In inputRange.Areas
        ' Loop through each cell in the area
        For Each inputCell In inputArea
            Set outputCell = inputCell.Offset(0, 1).Cells(1)
            ' Split the value by dash
            Dim parts() As String
            If Len(inputCell.Value) > 0 Then
                resList = ""
            ElseIf Len(inputCell.Value) = 0 Then ' blank cell
                Debug.Print "blank"
                'the same as previous
                'resList = resList
            ElseIf IsEmpty(inputCell) Then
                Debug.Print "empty"
                resList = ""
            End If
            If Len(inputCell.Value) > 0 Then
                parts = Split(Replace(inputCell.Value, ",", " "), " ")
                For i = LBound(parts) To UBound(parts)
                    If Len(Trim(parts(i))) > 0 Then
                        resList = resList & ExpandCellsList(Trim(parts(i))) & " "
                    End If
                Next i
                If Len(resList) > 0 Then resList = Left(resList, Len(resList) - 1)
            End If
            Debug.Print outputCell.Address, resList
            outputCell.Value = resList
        Next inputCell
    Next inputArea
End Sub

Public Function ExpandCellsList(cl As String) As String
Dim i As Long
Dim sH As String, sv1 As String, sv2 As String
Dim startNum As Long, endNum As Long
Dim res As String
    i = InStr(1, cl, "-")
    If i > 0 Then
        sv2 = Trim(Mid(cl, i + 1))
        sH = Trim(Left(cl, i - 1))
        For i = 1 To Len(sH)
            If InStr(1, "01234567890", Mid(sH, i, 1)) > 0 Then
                sv1 = Trim(Mid(sH, i))
                sH = Trim(Left(sH, i - 1))
                Exit For
            End If
        Next i
        If Len(sv2) < Len(sv1) Then
            sv2 = Left(sv1, Len(sv1) - Len(sv2)) & sv2
        End If
        startNum = Val(sv1)
        endNum = Val(sv2)
        If endNum > startNum Then
            For i = startNum To endNum
                res = res & sH & CStr(i) & " "
            Next i
        End If
        If Len(res) > 0 Then res = Left(res, Len(res) - 1)
        ExpandCellsList = res
    Else
        ExpandCellsList = cl
    End If
End Function
Solution

  • Ony some corrections, pls. check. Mark changes and additions.

    Dim sH As String       'Added
Sub ParseCell()
' Set the input range where your values are
Dim inputRange As Range, outputCell As Range, inputArea As Range
Dim inputCell As Variant
Dim startNum As Long, endNum As Long
Dim i As Long
Dim resList  As String
Debug.Print "Selection_change"

Set inputRange = Selection.Columns(1) ' Added Use the selected range as input

' Set the output range where you want the split references
Set outputCell = inputRange.Offset(0, 1).Cells(1) ' Output in the column next to the input

    ' Loop through each area in the input range
    resList = ""
    For Each inputArea In inputRange.Areas
        ' Loop through each cell in the area
        For Each inputCell In inputArea
            Set outputCell = inputCell.Offset(0, 1).Cells(1)
            ' Split the value by dash
            Dim parts() As String
            If Len(inputCell.Value) > 0 Then
                resList = ""
            ElseIf Len(inputCell.Value) = 0 Then ' blank cell
                Debug.Print "blank"
                'the same as previous
                'resList = resList
            ElseIf IsEmpty(inputCell) Then
                Debug.Print "empty"
                resList = ""
            End If
            If Len(inputCell.Value) > 0 Then
                parts = Split(Replace(inputCell.Value, ",", " "), " ")
                For i = LBound(parts) To UBound(parts)
                    If Len(Trim(parts(i))) > 0 Then
                        resList = resList & ExpandCellsList(Trim(parts(i))) & " "
                    End If
                Next i
                If Len(resList) > 0 Then resList = Left(resList, Len(resList) - 1): outputCell.Value = resList  'Moved here
            End If
            Debug.Print outputCell.Address, resList
        Next inputCell
    Next inputArea
End Sub

Public Function ExpandCellsList(cl As String) As String
Dim i As Long
Dim sv1 As String, sv2 As String, shdepo As String   'Added
Dim startNum As Long, endNum As Long
Dim res As String
    i = InStr(1, cl, "-")
    If i > 0 Then
        sv2 = Trim(Mid(cl, i + 1))
        shdepo = sH
        sH = Trim(Left(cl, i - 1))
        For i = 1 To Len(sH)
            If InStr(1, "01234567890", Mid(sH, i, 1)) > 0 Then
                sv1 = Trim(Mid(sH, i))
                sH = Trim(Left(sH, i - 1))
                If Len(sH) = 0 Then sH = shdepo   'Added
                Exit For
            End If
        Next i
        If Len(sv2) < Len(sv1) Then
            sv2 = Left(sv1, Len(sv1) - Len(sv2)) & sv2
        End If
        startNum = Val(sv1)
        endNum = Val(sv2)
        If endNum > startNum Then
            For i = startNum To endNum
                res = res & sH & CStr(i) & " "
            Next i
        End If
        If Len(res) > 0 Then res = Left(res, Len(res) - 1)
        ExpandCellsList = res
    Else
        sH = Left(Trim(cl), 1)    'Added
        ExpandCellsList = cl
    End If
End Function