how to get multiple lookup values in one cell using vba code for static LookupValue, LookupRange , ColumnNumber, delimiter from different sheets

user_16120425 0
Viewed 48

For ex: I have two sheets Sheet 1 & Sheet 2

enter image description here

enter image description here

enter image description here

I'm using the below code, which is very slow and have to pass values. I need to built a code without passing values and look between the sheets. Kindly guide me how to do that. Thanks in advance

```
Function SingleCellExtract(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, 
Char As String)
    Dim I As Long
Dim xRet As String
For I = 1 To LookupRange.Columns(1).Cells.Count
    If LookupRange.Cells(I, 1) = LookupValue Then
        If xRet = "" Then
            xRet = LookupRange.Cells(I, ColumnNumber) & Char
        Else
            xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
        End If
    End If
 Next
SingleCellExtract = Left(xRet, Len(xRet) - 1)
End Function
```
vba excel
1 Answers

Take a look at Dictionary Objects

Option Explicit

Sub macro1()

    Dim dict As Object, lastrow As Long, r As Long, n As Long
    Dim key As String, t0 As Single: t0 = Timer
    Set dict = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet2")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).row
        For r = 2 To lastrow
            key = Trim(.Cells(r, "A"))
            If dict.exists(key) Then
                dict(key) = dict(key) & "," & Trim(.Cells(r, "B"))
            ElseIf Len(key) > 0 Then
                dict(key) = Trim(.Cells(r, "B"))
            End If
        Next
    End With
  
    With Sheets("Sheet1")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).row
        For r = 2 To lastrow
            key = Trim(.Cells(r, "A"))
            If dict.exists(key) Then
                .Cells(r, "B") = dict(key)
                n = n + 1
            End If
        Next
    End With
    MsgBox n & " Rows updated", vbInformation, Format(Timer - t0, "0.0 secs")
  
End Sub
user_127045930
Related