Hi

Hopefully someone can help.
My code searches the activesheet for a value (currency) that is in a list on a seperate sheet, it will go down the list until it has found one. Once it has found the value in the activesheet (e.g. GBP) it will delete all the cells before it leaving GBP in column A. It will then find the next GBP and delete all the cells before that.
The trouble I am having is that if GBP appears on the same row more than once it will delete all instances. How can I change the code so it only runs the code once per row and then move onto the next. 

Sub Test()
Dim rList As Range     'search terms
Dim rsearch As Range    'cells to search
Dim rCl As Range
Dim rFound As Range
Dim ToSheet As Worksheet
Dim ToRow As Long
     
    Set rsearch = ActiveSheet.UsedRange  'set multifond range to search
    Set ToSheet = ActiveSheet
    ToRow = ToSheet.Range("C65536").End(xlUp).Row
    
    With Workbooks("Commandsheet").Sheets("Lookups")
        Set rList = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'set lookup sheet as search terms
    End With
    
    For Each rCl In rList
        Set rFound = rsearch.Find(rCl.Value, LookIn:=xlValues, lookat:=xlWhole)

'Loop through column A and see if value is in the lookup table.
If Not rFound Is Nothing Then
    Do
        If rFound.Column >1 Then
        
            With ActiveSheet
                 .Range(.Cells(rFound.Row, 1), .Cells(rFound.Row, rFound.Column - 1)).Delete shift:=xlShiftToLeft
              End With
              
         End If
      
      Set rFound = rsearch.FindNext(rFound)
      Loop While Not rFound Is Nothing And rFound.Column <> 1
      
End If
Next
Any help would be much appreciated. Thanks