loop function keeps running VBA Excel

Question

I need your help to get my code working.

I made a code to copy values of cell from one sheet to another, i needed a loop in the code to copy all the values and stop when the first value reached again. So far so good.

But when i change the code to find other things (example "2 X" with B as range) the loop keeps going and pasting values in my sheet, and can't be stopt.

Below is the code that works.

SO i need a code that does the same, but with different terms, i hope you guys can help me.

Dim A As Range 
Sheet5.Activate 
Cells.Find(what:="1 X ", after:=ActiveCell, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False , searchformat:=False).Copy 
ActiveCell.Select 
Set A = ActiveCell 
Sheet75.Activate 
row_number = row_number + 1 
Cells(row_number, 2).Select 
ActiveCell.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False 
Do 
Blad5.Activate 
Cells.FindNext(after:=ActiveCell).Select 
Cells.FindNext(after:=ActiveCell).Copy 
Sheet75.Activate 
row_number = row_number + 1 
Cells(row_number, 2).Select 
ActiveCell.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False 
Loop Until ActiveCell.Value = A.Value 

Thank you and srry for bad english.

Answer 1

Welcome to SO, please take a minute to take the tour : https://stackoverflow.com/tour

I also STRONGLY advise that you read the links shared in comments.

---

I changed the .Copy/.PasteSpecial which is very slow and as you only want to transfer values, this is a much faster method! ;)

Here is how to properly use the .Find method :

Sub test_Steelbox()
Dim FirstAddress As String, _
    cF As Range, _
    LookUpValue As String, _
    ShCopy As Worksheet, _
    ShPaste As Worksheet, _
    Row_Number As Double

''Setup here
Row_Number = 2
LookUpValue = "2 X"
Set ShCopy = ThisWorkbook.Sheets(Sheet5.Name) ''for example "data"
Set ShPaste = ThisWorkbook.Sheets(Sheet75.Name) ''for example "summary"

With ShCopy
    .Range("A1").Activate
    With .Cells
        ''First, define properly the Find method
        Set cF = .Find(What:=LookUpValue, _
                    After:=ActiveCell, _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)

        ''If there is a result, do your data transfer and keep looking with FindNext method
        If Not cF Is Nothing Then
            FirstAddress = cF.Address
            Do
                ''This is much much faster than copy paste!
                ShPaste.Cells(Row_Number, 2).Value = cF.Value
                Row_Number = Row_Number + 1

                Set cF = .FindNext(cF)
            ''Loop until you find again the first result
            Loop While Not cF Is Nothing And cF.Address <> FirstAddress
        End If
    End With
End With

End Sub