Using a For loop to find a single value then execute code-CodePudding

the purpose of my macro is to find a certain value "MI (D)" within column B then execute code based on the surrounding cells. Sometimes there's only one value, sometimes there can be more. How can I code my for loop so it starts with the first one, then checks the column for more? Right now my code does the first one perfectly, but if there is a second, third one, etc it doesn't execute.


Dim Rng As Range
Dim cell As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
Set Rng = Range("B:B").Find("MI (D)")

For Each cell In Rng
    
If Not Rng Is Nothing Then
    Rng.Select
End If
    
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, ActiveCell.Offset(0, 1)).Select
Selection.Copy
    
    'For Each cell In ws.Columns(3).Cells
    '    If IsEmpty(cell) = True Then cell.Select: Exit For
    'Next cell
    
Dim LastRow As Long

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(LastRow, 3).Offset(1, 0).Select
    
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(-3, 0).Select

ActiveCell = ActiveCell - 1
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell   25

ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 1
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell   25
    
ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 11
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell   50

ActiveCell.Offset(1, -1).Select
ActiveCell = ActiveCell - 11
ActiveCell.Offset(0, 1).Select
ActiveCell = ActiveCell   50


Rng.Select
ActiveCell.Offset(0, -1).Select
Selection.Copy

'For Each cell In ws.Columns(1).Cells
'    If IsEmpty(cell) = True Then cell.Select: Exit For
'Next cell

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(LastRow, 1).Offset(1, 0).Select

Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, 1).Select
Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues
ActiveCell.Offset(1, 1).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(-3, 0).Select

Selection = "ON (D)"
Selection.Copy

ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues

ActiveCell.Offset(1, 1).Select
Selection = "ON (I)"
Selection.Copy
ActiveCell.Offset(1, -1).Select
Selection.PasteSpecial paste:=xlPasteValues

Next cell
End sub```

[![enter image description here][1]][1]


  [1]: https://i.stack.imgur.com/ltM8S.png

CodePudding user response：

Find Multiple Matches (`Find/FindNext`)

Sub UpdateMyData()

    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 ' improve!
    ' 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
    
    MsgBox "Data updated.", vbInformation
    
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

Find Multiple Matches (Find/FindNext)

Find Multiple Matches (`Find/FindNext`)