Search for a specific value in two columns and return a single result

[Sir_Calvin]

Right now, my code searched for "MI (D)" in column "B" and adds 4 additional lines at the bottom of the code dependent on what State is next to that value in column "A". However, there are some instances where there are many "MI (D)" combinations, so the code cycles through each one and adds dozens of lines of data. Is there a way to search for the "MI (D)" value in both columns "A" and "B" and execute the code only once? Each file is unique so I'm looking for one macro that is all encompassing.

Sub Add_ON_Lanes()

If Range("A:A").Find(What:="ON", LookAt:=xlPart) Is Nothing Then
    
    ActiveSheet.Range("B:B").Replace What:="MI (D) ", replacement:="MI (D)"
    Range("C:C").NumberFormat = "0.0"
        
    Const SOURCE_FIRST_CELL_ADDRESS As String = "B2"
    Const CRITERION As String = "MI (D)"
    Const DESTINATION_COLUMN As String = "A"
    Const DESTINATION_ROWOFFSET As Long = 4

    Dim ws As Worksheet: Set ws = ActiveSheet
    ' The Find method will fail if the worksheet is filtered:
    If ws.FilterMode Then ws.ShowAllData
    
    Dim srg As Range
    With ws.Range(SOURCE_FIRST_CELL_ADDRESS)
        Set srg = Intersect(.Resize(ws.Rows.Count - .Row + 1), ws.UsedRange)
    End With
    
    Dim slCell As Range: Set slCell = srg.Cells(srg.Cells.Count) ' last
    
    Dim dfCell As Range
    Set dfCell = slCell.Offset(1).EntireRow.Columns(DESTINATION_COLUMN) ' first
    
    Dim sfCell As Range
    ' If the cells contain values:
    Set sfCell = srg.Find(CRITERION, slCell, xlFormulas, xlWhole)
    ' If the cells contain formulas, replace 'xlFormulas' with 'xlValues'.
    ' in the latter case, make sure there are no hidden rows,
    ' or the Find method will fail.
    
    If sfCell Is Nothing Then
        MsgBox "The criterion '" & CRITERION & "' was not found.", vbExclamation
        Exit Sub
    End If
    
    Dim SourceFirstCellAddress As String
    SourceFirstCellAddress = sfCell.Address
    
    Do
        WriteMyData sfCell, dfCell ' write
        Set sfCell = srg.FindNext(sfCell) ' find next
        Set dfCell = dfCell.Offset(DESTINATION_ROWOFFSET)
    Loop Until sfCell.Address = SourceFirstCellAddress
    
Else
    MsgBox "Customer already has Ontario lanes!", vbOKOnly, "Whoops!"
    Exit Sub
End If

End Sub

Sub WriteMyData( _
        ByVal sfCell As Range, _
        ByVal dfCell As Range)
    
    Dim sData() As Variant: sData = sfCell.Offset(, -1).Resize(, 4).Value
    Dim dData() As Variant: ReDim dData(1 To 4, 1 To 4)
    
    dData(1, 1) = sData(1, 1)
    dData(2, 1) = "ON (D)"
    dData(3, 1) = sData(1, 1)
    dData(4, 1) = "ON (I)"
    
    dData(1, 2) = "ON (D)"
    dData(2, 2) = sData(1, 1)
    dData(3, 2) = "ON (I)"
    dData(4, 2) = sData(1, 1)
    
    dData(1, 3) = sData(1, 3) - 1
    dData(2, 3) = sData(1, 3) - 1
    dData(3, 3) = sData(1, 3) - 11
    dData(4, 3) = sData(1, 3) - 11
    
    dData(1, 4) = sData(1, 4) + 25
    dData(2, 4) = sData(1, 4) + 25
    dData(3, 4) = sData(1, 4) + 50
    dData(4, 4) = sData(1, 4) + 50
    
    dfCell.Resize(4, 4).Value = dData


End Sub

I don't need the AL, AR, AZ values returned

I need this value returned, as well as the "IN" / "MI (D)" further down

This is what I need the code to do: