For Each Loop , Excel VBA

Question

I have an excel file that is the outcome of a PDF to Excel conversion. The data in the excel file did not come clean for some of the columns.

What needs to be accomplished:

I have created a For Each loop to go over Column "B" and find the Auction Number. Once found, a second For Each loop was created to go over Column "E" and find the first occurrence of an address and cut this cell and move it to the same row of the auction number.

Problem:

The second for each loop keeps starting from the top of column "E" and not from where the for each loop row number in column "B" ended.

The Code is about 85% complete and no errors when running

    Sub Macro1()

    Dim rCell As Range
    Dim rCell2 As Range


    Dim rCell3 As Range

    Dim rRng As Range
    Dim rRng2 As Range
    Dim rRng3 As Range

    Dim i As Integer
    Dim j As Integer

    Dim strMyValue As String

    Set rRng = Sheet2.Range("B:B")
    Set rRng2 = Sheet2.Range("E:E")
    Set rRng3 = Sheet2.Range("F:F")

    i = 0
    j = 0

    For Each rCol In rRng.Columns

        For Each rCell In rCol.Rows

            If InStr(rCell.Value, "FEB") > 1 Then

              i = rCell.Row

        Debug.Print rCell.Address, rCell.Value, rCell.Row, i


                 For Each rCol2 In rRng2.Columns
                       For Each rCell2 In rCol2.Rows


             If InStr(rCell2.Value, ", PA 1") > 1 Then

                      If InStr(Cells(rCell2.Row + 1, "E"), ", PA 1") = 0 Then
                              Debug.Print Cells(rCell2.Row + 1,"E").Value
                      Else
                           Cells(rCell2.Row + 1, "E").Clear

                     End If


                     rCell2.Cut Cells(rCell.Row, "D")

                    Exit For

           End If

         Next rCell2

     Next rCol2

    End If


        Next rCell
    Next rCol


    End Sub

Appreciate any help. I just cant solve it ..

Answer 1

Can you try this? You have more loops than you need as your ranges are only single columns; also no need to iterate through all million rows, just the used bits.

Sub Macro1()

Dim rCell As Range
Dim rCell2 As Range
Dim rCell3 As Range

Dim rRng As Range
Dim rRng2 As Range
Dim rRng3 As Range
Dim rCol As Range
Dim rCol2 As Range

Dim i As Long
Dim j As Long

Dim strMyValue As String

With Sheet2
    Set rRng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
    Set rRng3 = .Range("F1", .Range("F" & Rows.Count).End(xlUp))
End With

For Each rCell In rRng
    If InStr(rCell.Value, "FEB") > 1 Then
        i = rCell.Row
        Debug.Print rCell.Address, rCell.Value, rCell.Row, i
        With Sheet2
            Set rRng2 = .Range(.Cells(i, "E"), .Cells(.Rows.Count, "E").End(xlUp))
        End With
        For Each rCell2 In rRng2
            If InStr(rCell2.Value, ", PA 1") > 1 Then
                If InStr(rCell2.Offset(1), ", PA 1") = 0 Then
                    Debug.Print rCell2.Offset(1).Value
                Else
                    rCell2.Offset(1).Clear
                End If
                rCell2.Cut rCell2.Offset(,-1)
                Exit For
            End If
        Next rCell2
    End If
Next rCell

End Sub

Answer 2

screen shot

Thanks SJR..

I attached a screen shot of the workbook. so far you have helped me in getting the loop working for each Auction Number in column "B" to go and find the address in column "E" and place it in column "D" on the same row of the auction No.

The problems that i am facing now are two. 1.having two addresses for that auction no. 2.Not having an address at all.

The solution the i have now with code will do the following: getting only the first address and placing it correctly but leaving the other addresses. And if their is no address like for the auction number "003FEB18", the loop will pick up cell E21 "112 WASHINGTON PLACE UNIT 4A" and place it wrongfully on cell D13 for auction number "003FEB18"

For Each rCell In rRng
    If InStr(rCell.Value, "FEB") > 1 Then
        i = rCell.Row
        'Debug.Print rCell.Address, rCell.Value, rCell.Row, i
        With Sheet2
            Set rRng2 = .Range(.Cells(i, "E"), .Cells(.Rows.count, 
    "E").End(xlUp))
            End With
                For Each rCell2 In rRng2
                If InStr(rCell2.Value, ", PA 1") > 1 Then

                rCell2.Cut Cells(rCell.Row, "D") 'rCell2.Offset(, -1)
                Exit For
            End If
        Next rCell2
    End If
Next rCell