Find Value in Range then copy that to a new worksheet Loop

[mjmarian1]

I have an excel spread sheet that has account information for users. There are multiple occurrences of a value in column B that say "Account Name:" and I need to copy the value that is next to it in Row D and paste it in Column A of a different worksheet in that workbook called Data. I need to repeat this in a range from B1:B20000. I cant get it to move past the first occurrence of the value "Account Name:" and I also don't know how to make it check to see if there is value in the first cell on the worksheet called Data is blank to paste that value into.

Dim aN As RangeSet aN = Range("B1:B20000")


    'Loop through every used cell in the active worksheet
    For Each aN In ActiveSheet.UsedRange
           
        If ActiveCell = "Account Name:" Then
           ActiveCell.Offset(0, 2).Select
           ActiveCell.Copy
           Sheets("Data").Select
           ActiveCell.PasteSpecial
           Sheets("Table4").Select
           ActiveCell.Offset(0, -2).Select
        Else: ActiveCell.Offset(1, 0).Select
        
       End If
       
    Next
 End Sub

 

[mumps]

Try:

Sub CopyCell()
    Application.ScreenUpdating = False
    Dim sAddr As String
    Dim foundAN As Range
    Set foundAN = Range("B:B").Find("Account Name", LookIn:=xlValues, lookat:=xlWhole)
    If Not foundAN Is Nothing Then
        sAddr = foundAN.Address
        Do
            foundAN.Offset(0, 2).Copy Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Set foundAN = Range("B:B").FindNext(foundAN)
        Loop While foundAN.Address <> sAddr
        sAddr = ""
    End If
    Set foundAN = Nothing
    Application.ScreenUpdating = True
End Sub

 

[mjmarian1]

Thank you that worked!

 

[mumps]

You are very welcome.