How to populate a multiple results, using vlookup in MS excel?

[jkevz01]

Hi! I am new in VBA. I copied this code from other source. This code populates only one (1) result which is in column C13, my lookup value are in Sheet1 B13:B31. I want to display the result also in other column which is in H13. My Table array are in Sheet4 column A:E. My codes are below:


Sub Vlookup()

Dim c As Range, v, v1, v2, rngSearch As Range

Set rngSearch = Sheet4.Range("A:E")

For Each c In Sheet1.Range("B13:B31").Cells 'loop the input range
v = c.Value
If Len(v) > 0 Then 'is there anything to look up?
'drop the `WorksheetFunction` to prevent run-time
'error if there's no match
v1 = Application.Vlookup(v, rngSearch, 3, False)
c.EntireRow.Columns("C").Value = IIf(IsError(v1), "Please Write Manually the Item Description", v1) ' "-" if no match
End If
Next c
End Sub

 

[bebo021999]

Option Explicit
Sub Vlookup()
Dim cella As Range, cellb As Range, k&
For Each cella In Sheet1.Range("B13:B31") ' lookup value
    For Each cellb In Sheet4.Range("A1:A" & Sheet4.Cells(Rows.Count, "A").End(xlUp).Row) 'lookup range
    Debug.Print cella, cellb
        If cella = "" Then
            cella.Offset(0, 1).Value = "Nothing to vlookup" ' write to column C
            Exit For
        ElseIf cella = cellb.Value Then
            cella.Offset(0, 1).Value = cellb.Offset(0, 2).Value ' write to column C
            cella.Offset(0, 6).Value = cellb.Offset(0, 2).Value ' write to column H
            k = k + 1
            Exit For
        End If
    If k = 0 Then cella.Offset(0, 1).Value = "Please Write Manually the Item Description"
    Next
k = 0
Next
End Sub

 

[jkevz01]

Option Explicit
Sub Vlookup()
Dim cella As Range, cellb As Range, k&
For Each cella In Sheet1.Range("B13:B31") ' lookup value
    For Each cellb In Sheet4.Range("A1:A" & Sheet4.Cells(Rows.Count, "A").End(xlUp).Row) 'lookup range
    Debug.Print cella, cellb
        If cella = "" Then
            cella.Offset(0, 1).Value = "Nothing to vlookup" ' write to column C
            Exit For
        ElseIf cella = cellb.Value Then
            cella.Offset(0, 1).Value = cellb.Offset(0, 2).Value ' write to column C
            cella.Offset(0, 6).Value = cellb.Offset(0, 2).Value ' write to column H
            k = k + 1
            Exit For
        End If
    If k = 0 Then cella.Offset(0, 1).Value = "Please Write Manually the Item Description"
    Next
k = 0
Next
End Sub

This code keeps on running and it won't stop. the result in c13 won't come up

 

[Fluff]

How about

Sub jkevz()
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scrpting.dictionary")
   With Sheet4
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Value) = Cl.Offset(, 2).Value
      Next Cl
   End With
   With Sheet1
      For Each Cl In .Range("B13:B31")
         If Dic.Exists(Cl.Value) Then
            Cl.Offset(, 6).Value Dic(Cl.Value)
         Else
            Cl.Offset(, 6).Value = "Please Write Manually the Item Description"
         End If
      Next Cl
   End With
End Sub