VBA - Lookups based on cell input and exit

[JayBurn]

Morning All

I'm looking for some help making a pricing tool a little cleaner and without formulas. Essentially, what I have is a sheet 'Input_5' where cells B23:B72 is for entering a product code, then in cells D23:D72 would be the description of the said product, Columns G, H and I show different costs. The descriptions and costs are help on worksheet 'Data' columns C to F respectively.

Anybody able to help with out with a VBA solution to automatically populate 'Input_5' columns D, G, H and I without using formulas so the resulting text can be selected and copied without needing to copy and paste special the values?

The cells in B23:B72 won't all be used, so if there is a way that only the row where the B~ cell is being exited is triggered, that would be brilliant.

Help me Excel Guru's, you're my only hope...

Cheers all.

 

[JayBurn]

So I solved it inefficiently myself, but hopefully someone can help streamline it...

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
 
    Set KeyCells = Range("B23:B72")
   
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
          
       On Error Resume Next
      
           Range("D23") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B23"), Sheets("VS Data").Range("B1:C5000"), 2, False)
           Range("G23") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B23"), Sheets("VS Data").Range("B1:D5000"), 3, False)
           Range("H23") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B23"), Sheets("VS Data").Range("B1:E5000"), 4, False)
           Range("I23") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B23"), Sheets("VS Data").Range("B1:F5000"), 5, False)
           Range("D24") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B24"), Sheets("VS Data").Range("B1:C5000"), 2, False)
           Range("G24") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B24"), Sheets("VS Data").Range("B1:D5000"), 3, False)
           Range("H24") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B24"), Sheets("VS Data").Range("B1:E5000"), 4, False)
           Range("I24") = Application.WorksheetFunction.VLookup(Sheets("Input Sheet").Range("B24"), Sheets("VS Data").Range("B1:F5000"), 5, False)
 
On Error GoTo MyErrorHandler
 
MyErrorHandler:
If Err.Number = 1004 Then
Result = ""
End If

This is repeated down to row 72, meaning 200 rows of vlookups. Anyone able to suggest a way of looping back to the first of the four lookup rows and adding one to the row number until stopping at 72?

Cheers

 

[Fluff]

Untested
If you are only entering the values one at a time, rather than pasting them in how about

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim Rw As Long
 
    Set KeyCells = Range("B23:B72")
   
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
        Rw = Target.Row
       On Error Resume Next
      
           Range("D" & Rw) = Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:C5000"), 2, False)
           Range("G" & Rw) = Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:D5000"), 3, False)
           Range("H" & Rw) = Application.WorksheetFunction.VLookup(Target.Value, Sheets("VS Data").Range("B1:E5000"), 4, False)
           Range("I" & Rw) = 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

 

[JackDanIce]

Untested, try:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim arr()   As Variant
    Dim temp    As Variant
    Dim x       As Long
    Dim dic     As Object
    
    Const DELIM As String = "|"
   
    If Intersect(Cells(23, 2).Resize(50, 1), Target) Is Nothing Then Exit Sub

    Set dic = CreateObject("Scripting.Dictionary")

    With Sheets("VS Data")
        x = .Cells(.Rows.count, 2).End(xlUp).row
        arr = .Cells(2, 1).Resize(x, 5).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
    Next x
    
    arr = Cells(2, 23).Resize(50, 5).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 3) = Split(dic(arr(x, 1)), DELIM)(1)
        arr(x, 6) = Split(dic(arr(x, 1)), DELIM)(2)
        arr(x, 7) = Split(dic(arr(x, 1)), DELIM)(3)
        arr(x, 8) = Split(dic(arr(x, 1)), DELIM)(4)
    Next x
        
    temp = Array(3, 6, 7, 8)
    For x = LBound(temp) To UBound(temp)
        Cells(23, x + 1).Resize(UBound(arr, 1)) = Application.Index(arr, , x)
    Next x
    
    Set dic = Nothing
    Erase arr
        
End Sub

 

[JayBurn]

Worked a treat, thanks Fluff!

 

[Fluff]

Glad to help & thanks for the feedback

 

[JackDanIce]

Sorry, ignore mine misread the post and @Fluff's suggestion works!