Question

Edit: I figured it out, thanks to a helpful post. My final code is below.

I am using Excel, and I've got this VBA script that looks for a string, copies it, then pastes it two cells down. What I'd like to do is have the process repeat for the entire sheet until it reaches the last occurrence.

Can someone please help me put this into a loop or something similar?

Sub PasteOffset()
    Dim rng1 As Range
    Dim strSearch As String
    strSearch = "Transaction Number*"

    Set rng1 = Range("A:A").Find(strSearch, , xlValues, xlWhole)

    If Not rng1 Is Nothing Then
    rng1.Select
    rng1.Copy
    rng1.Offset(2, 0).PasteSpecial

    Else
    MsgBox "all done"

    End If
    End Sub
Was it helpful?

Solution

This works:

Sub PasteOffset()

Dim rng1 As Range
Dim strSearch As String
strSearch = "Transaction Number*"

For CellNumber = 355 To 1 Step -1
Set rng1 = Range("A" & CellNumber)

If rng1.Value Like strSearch Then
    rng1.Select
    rng1.Copy
    rng1.Offset(2, 0).PasteSpecial
End If

Next CellNumber
End Sub

OTHER TIPS

Something like this ? :

Sub PasteOffset()

Dim rng1 As Range
Dim strSearch As String
strSearch = "Transaction Number*"

For CellNumber = 300 to 1 Step -1 'Write the end number here (instead of 300)
    Set rng1 = Range("A" & CellNumber )

    If rng1.Value = strSearch Then
        rng1.Select
        rng1.Copy
        rng1.Offset(2, 0).PasteSpecial
    End If

Next CellNumber 
End Sub

Give this a try:

Sub tgr()

    Dim rngFound As Range
    Dim rngAll As Range
    Dim AllCell As Range
    Dim strSearch As String
    Dim strFirst As String

    strSearch = "Transaction Number*"

    Set rngFound = Columns("A").Find(strSearch, Cells(Rows.Count, "A"), xlValues, xlWhole)
    If Not rngFound Is Nothing Then
        Set rngAll = rngFound
        strFirst = rngFound.Address
        Do
            Set rngAll = Union(rngAll, rngFound)
            Set rngFound = Columns("A").Find(strSearch, rngFound, xlValues, xlWhole)
        Loop While rngFound.Address <> strFirst

        For Each AllCell In rngAll.Cells
            AllCell.Copy
            AllCell.Offset(2).PasteSpecial
        Next AllCell
        Application.CutCopyMode = False
    End If

End Sub
Licensed under: CC-BY-SA with attribution
Not affiliated with StackOverflow
scroll top