Creating cells with ranges from a list of ranges and exclusions-CodePudding

I have a list of ranges and a list of exclusions on excel cells. I want to make a new list of ranges that takes into account the exclusions. Note that the first entry is always the lower bound and the second is always the upper bound. There are sometimes blank spaces between the cells in both exclusions and ranges. Here is an example with the code output given in black

The code is below, note that everything in between quotation rows with msg boxes is merely for your convenience(error testing). I must not be far off, the problem I think is that the code needs to be forward-looking? Also, I am guessing sharing an excel sheet is against community guidelines.

Edit: I have been asked to explain the logic more fully so I am putting it here. The first exclusion range is 111000222-111000333, ordinarily is this would mean that the larger range would stop at 111000221 and then pick up again at 1110003334.

But since the next exclusion range is 111000334 to 111000444, then we have to to start at the end of the second exclusion range, at 111000445. This is because the upper of the first exclusion range 1 is equal to the lower of the second exclusion range.

''
Sub Macro2()
'
' Macro2 Macro
'

Dim inrange As Range, outrange As Range, current As Range, goodcell As Range, badcell As Range, w As Integer


'counter for inrange loop
k = 1
'counter for outrange loop
c = 1
'Current X coordinate
Row = 13
Column = 5

Range("A13:CW13").Clear
Set inrange = Range("E7:BL7")
Set outrange = Range("E9:BV9")
Set current = Cells(Row, Column)



For Each goodcell In inrange
    If Len(goodcell.Value) = 9 And k = 1 Then
        lower_range = goodcell.Value
        ''''''''''''''''''''''''''''''''''''''
        Cells(17, 3) = lower_range
        MsgBox "Step 1"
        ''''''''''''''''''''''''''''''''''''''
        k = 2
    ElseIf Len(goodcell.Value) = 9 And k = 2 Then
        upper_range = goodcell.Value
        ''''''''''''''''''''''''''''''''''''''
        Cells(17, 5) = upper_range
        MsgBox "Step 2"
        ''''''''''''''''''''''''''''''''''''''
        For Each badcell In outrange
            If Len(badcell) = 9 And c = 1 Then
                blower_range = badcell.Value
                ''''''''''''''''''''''''''''''''''''''
                Cells(17, 4) = blower_range
                MsgBox "Step 3"
                ''''''''''''''''''''''''''''''''''''''
                c = 2
            ElseIf Len(badcell.Value) = 9 And c = 2 Then
                bupper_range = badcell.Value
                ''''''''''''''''''''''''''''''''''''''
                Cells(17, 6) = bupper_range
                MsgBox "Step 4"
                ''''''''''''''''''''''''''''''''''''''
                If upper_range > bupper_range And lower_range < blower_range And blower_range < bupper_range And old_bupper_range   1 <> blower_range Then
                    current.Value = lower_range
                    ''''''''''''''''''''''''''''''''''''''
                    Cells(17, 7) = current.Value
                    MsgBox "Step 5"
                    ''''''''''''''''''''''''''''''''''''''
                    Column = Column   1
                    Set current = Cells(Row, Column) 'to the right
                    If lower_range <> old_bupper_range Then
                        current.Value = blower_range - 1
                        Column = Column   1
                        Set current = Cells(Row, Column) 'to the right
                    End If
                    ''''''''''''''''''''''''''''''''''''''
                    Cells(17, 7) = current.Value
                    MsgBox "Step 6"
                    ''''''''''''''''''''''''''''''''''''''

                    old_bupper_range = bupper_range   1
                    lower_range = bupper_range   1
                    ''''''''''''''''''''''''''''''''''''''
                    Cells(17, 2) = old_bupper_range
                    Cells(17, 3) = lower_range
                    MsgBox "Step 7"
                    ''''''''''''''''''''''''''''''''''''''
                    c = 1
                End If
            End If
        Next badcell
        If lower_range <> blower_range Then
            current.Value = lower_range
            Column = Column   1
            Set current = Cells(Row, Column) 'to the right
        End If
        ''''''''''''''''''''''''''''''''''''''
        Cells(17, 7) = current.Value
        MsgBox "Step 8"
        ''''''''''''''''''''''''''''''''''''''
        current.Value = upper_range
        ''''''''''''''''''''''''''''''''''''''
        Cells(17, 7) = current.Value
        MsgBox "Step 9"
        ''''''''''''''''''''''''''''''''''''''
        Column = Column   1
        Set current = Cells(Row, Column) 'to the right
        k = 1
    End If
        
Next goodcell

'
            
End Sub
''

CodePudding user response：

This approach will combine continuous range first so that the result can be calculated from each exception range directly.

Class module - clsNumberRange

Public Lower As Long
Public Upper As Long

Standard module

Sub Test()
    'Collate range pairs into collection
    Const firstCol As Long = 5 '= E, starting column number for all 3 lists
    Const clearCol As Long = 101 '= CW, last column to clear content
    
    Const inputRow As Long = 7
    Const excepRow As Long = 9
    Const resultRow As Long = 13
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change the worksheet as needed
    
    'Collate input range into collection
    Dim inputColl As Collection
    Set inputColl = GetNumberRanges(inputRow, firstCol, ws)
    
    'Collate exception pairs into collection
    Dim excepColl As Collection
    Set excepColl = GetNumberRanges(excepRow, firstCol, ws)
    
    Dim resultColl As Collection
    Set resultColl = New Collection
    
    Dim resultPair As clsNumberRange
        
    Dim i As Long
    Dim n As Long
    Dim startExcep As Long
    
    For n = 1 To inputColl.Count
        'Find the first exception range that fits into current input range
        Set resultPair = New clsNumberRange
        resultPair.Lower = inputColl(n).Lower
        
        For startExcep = 1 To excepColl.Count
            If inputColl(n).Lower < excepColl(startExcep).Lower Then
                resultPair.Upper = excepColl(startExcep).Lower - 1
                Exit For
            End If
        Next startExcep
        resultColl.Add resultPair
                
        'Start getting result range outside from the remaining exception range
        For i = startExcep   1 To excepColl.Count
            Set resultPair = New clsNumberRange
            resultPair.Lower = excepColl(i - 1).Upper   1
            
            If excepColl(i).Lower < inputColl(n).Upper Then
                resultPair.Upper = excepColl(i).Lower - 1
            Else
                resultPair.Upper = inputColl(n).Upper
                resultColl.Add resultPair
                Exit For
            End If
            resultColl.Add resultPair
        Next i
        
        'If the last exception range is smaller than current input range then add another range into the result
        If inputColl(n).Upper > excepColl(excepColl.Count).Upper Then
            Set resultPair = New clsNumberRange
            resultPair.Lower = excepColl(excepColl.Count).Upper   1
            resultPair.Upper = inputColl(n).Upper
            resultColl.Add resultPair
        End If
    Next n
    
    Dim outputSize As Long
    outputSize = resultColl.Count * 2
    
    Dim outputArr() As Long
    ReDim outputArr(1 To 1, 1 To outputSize) As Long
    
    Dim resultCount As Long
    resultCount = 1
    For i = 1 To UBound(outputArr, 2) Step 2
        outputArr(1, i) = resultColl(resultCount).Lower
        outputArr(1, i   1) = resultColl(resultCount).Upper
        resultCount = resultCount   1
    Next i
    
    ws.Range(ws.Cells(resultRow, firstCol), ws.Cells(resultRow, clearCol)).Clear
    ws.Cells(resultRow, firstCol).Resize(, UBound(outputArr, 2)).Value = outputArr
End Sub

Private Function GetNumberRanges(inputRow As Long, inputStartCol As Long, ws As Worksheet) As Collection
    
    Dim inputLastCol As Long
    inputLastCol = ws.Cells(inputRow, ws.Columns.Count).End(xlToLeft).Column
    
    Dim inputArr As Variant
    inputArr = ws.Range(ws.Cells(inputRow, inputStartCol), ws.Cells(inputRow, inputLastCol)).Value
            
    Dim outputPairs As clsNumberRange
    Dim outputColl As Collection
    Set outputColl = New Collection
    
    Dim i As Long
    i = 1
    Do While i < UBound(inputArr, 2)
        If inputArr(1, i) <> vbNullString And inputArr(1, i   1) <> vbNullString Then
            
            'Allocate range in pairs into the collection
            Set outputPairs = New clsNumberRange
            With outputPairs
                .Lower = inputArr(1, i)
                .Upper = inputArr(1, i   1)
            End With
            outputColl.Add outputPairs
            i = i   1
        End If
        i = i   1
    Loop
    
    CollatePairs outputColl
    
    Set GetNumberRanges = outputColl
    Erase inputArr
End Function

Private Sub CollatePairs(argColl As Collection)
    If argColl.Count <> 1 Then
        Dim i As Long
        i = 1
        Do While i < argColl.Count
            'If the current range is continous from the next range, merge the range and discard next range from the collection
            Do While argColl(i).Upper   1 = argColl(i   1).Lower
                argColl(i).Upper = argColl(i   1).Upper
                argColl.Remove i   1
                If i = argColl.Count Then Exit Do
            Loop
            i = i   1
        Loop
    End If
End Sub