VBA - VLOOKUP for a potential pasted range

[JayBurn]

Morning All

A while ago I was given a bit of help to get this far, but now need a bit of tweaking.

I'm working on a product quoting tool, and it's doing a very basic vlookup using VBA. It works fine when a single product code is entered into a cell between B22:B121, however my sales guys will at times paste in multiple codes, and the VBA will only apply the lookup to the first row.

Here is what I'm using currently;

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim KeyCells As Range
    Dim Rw As Long
 
    Set KeyCells = Range("B22:B121")
   
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        Rw = Target.Row
       On Error Resume Next
        Range("C" & Rw).ClearContents
        Range("E" & Rw).ClearContents
        Range("F" & Rw).ClearContents
        Range("G" & Rw).ClearContents
        
           Range("C" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:C5000"), 2, False), "")
           Range("E" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:D5000"), 3, False), "")
           Range("F" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:E5000"), 4, False), "")
           Range("G" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:F5000"), 5, False), "")
            
On Error GoTo MyErrorHandler
 
MyErrorHandler:
If Err.Number = 1004 Then
result = ""
End If
End If

End Sub

I've played around with various loops, but can't figure out how best to get it repeating for each of the pasted cells rather than just the first...

Any advice?

 

[JayBurn]

No worries! Solved myself with a simple loop...

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim KeyCells As Range
    Dim Rw As Long
    Dim i As Integer
    
    Set KeyCells = Range("B22:B121")
    
   
    Rw = 22
    Do
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
       Is Nothing Then
         
    
       On Error Resume Next
        Range("C" & Rw).ClearContents
        Range("E" & Rw).ClearContents
        Range("F" & Rw).ClearContents
        Range("G" & Rw).ClearContents
        Range("C" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Range("B" & Rw), Sheets("VS Data").Range("B1:C5000"), 2, False), "")
        Range("E" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Range("B" & Rw), Sheets("VS Data").Range("B1:D5000"), 3, False), "")
        Range("F" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Range("B" & Rw), Sheets("VS Data").Range("B1:E5000"), 4, False), "")
        Range("G" & Rw) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Range("B" & Rw), Sheets("VS Data").Range("B1:F5000"), 5, False), "")

On Error GoTo MyErrorHandler
 
MyErrorHandler:
If Err.Number = 1004 Then
result = ""
End If
End If

Rw = Rw + 1
Loop While Rw < 122

End Sub