VBA - to Lookup a value in different worksheet - Then return all matches

[CF64]

Hello,
I have 2 worksheets - Devices and Departments

worksheet Devices has a list of Device IDs in Column A
worksheet Department has a list of department names in column A and a comma-delimited list of device IDs associated with that department (123xyz, 126xyz, 127xyz, 128xyz) in column B


Is there a way to look up the device ID from the Devices worksheet column A in the Department worksheets column B and return all departments separated by a comma, associated with that device ID into adjacent cells in column B of the Devices worksheet?


Devices Worksheet

DeviceIDs (column A)	Departments Found In (column B)
123xyz	Blue, Red, Yellow
124xyz	Red, Yellow
125xyz	Yellow

Department Worksheet

Department Name (column A)	DeviceIDs (column B)
Blue	123xyz, 126xyz, 127xyz, 128xyz
Red	123xyz, 124xyz, 129xyz
Yellow	123xyz, 124xyz, 125xyz, 130xyz

 

[offthelip]

try this:

Sub test()
With Worksheets("Department")
 lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
 departlist = .Range(.Cells(1, 1), .Cells(lastrow, 2))
 End With
 
With Worksheets("Devices")
 lastd = .Cells(Rows.Count, "A").End(xlUp).Row
 devicelist = .Range(.Cells(1, 1), .Cells(lastd, 2))
  For i = 2 To lastd
  devicelist(i, 2) = "" ' iniialise to blank
    For j = 2 To lastrow
     If InStr(departlist(j, 2), devicelist(i, 1)) > 0 Then
      devicelist(i, 2) = devicelist(i, 2) & departlist(j, 1) & ","
     End If
    Next j
      strlen = Len(devicelist(i, 2))
     If strlen > 0 Then
     devicelist(i, 2) = Left(devicelist(i, 2), strlen - 1) ' remove trailing comma
     End If
  Next i
  .Range(.Cells(1, 1), .Cells(lastd, 2)) = devicelist
 End With
End Sub

 

[noveske]

Tested and worked. Also added clear at the start of script.

Sub UpdateDepartmentWorksheet()
    Dim devicesWS As Worksheet
    Dim departmentWS As Worksheet
    Dim lastRow As Long
    Dim deviceRow As Long
    Dim departments As Variant
    Dim department As Variant
    Dim deviceID As String
    Dim departmentList As String
    Dim departmentDictionary As Object
   
    Set devicesWS = ThisWorkbook.Sheets("Devices")
    Set departmentWS = ThisWorkbook.Sheets("Department")
    Set departmentDictionary = CreateObject("Scripting.Dictionary")

    departmentWS.Rows("2:" & departmentWS.Rows.Count).Clear
   
    lastRow = devicesWS.Cells(devicesWS.Rows.Count, "A").End(xlUp).Row
   
    For deviceRow = 2 To lastRow
        deviceID = devicesWS.Cells(deviceRow, 1).Value
        departments = Split(devicesWS.Cells(deviceRow, 2).Value, ", ")
       
        For Each department In departments
            If Not departmentDictionary.Exists(department) Then
                departmentDictionary(department) = deviceID
            Else
                departmentDictionary(department) = departmentDictionary(department) & ", " & deviceID
            End If
        Next department
    Next deviceRow
   
    nextRow = 2
    For Each department In departmentDictionary.Keys
        departmentList = departmentDictionary(department)
        departmentWS.Cells(nextRow, 1).Value = department
        departmentWS.Cells(nextRow, 2).Value = departmentList
        nextRow = nextRow + 1
    Next department
   
    Set departmentDictionary = Nothing
End Sub

 

[Peter_SSs]

Does it really need to be vba? What about just this single formula in B2 of 'Devices' to return all the results spilled down the column?

CF64.xlsm
	A	B
1	Department	DeviceIDs
2	Blue	123xyz, 126xyz, 127xyz, 128xyz
3	Red	123xyz, 124xyz, 129xyz
4	Yellow	123xyz, 124xyz, 125xyz, 130xyz
Department

CF64.xlsm
	A	B
1	DeviceIDs	Departments
2	123xyz	Blue, Red, Yellow
3	124xyz	Red, Yellow
4	125xyz	Yellow
Devices

Cell Formulas
Range	Formula
B2:B4	B2	=BYROW(A2:A4,LAMBDA(id,TEXTJOIN(", ",1,FILTER(Department!A2:A4,ISNUMBER(SEARCH(" "&id&","," "&Department!B2:B4&",")),""))))
Dynamic array formulas.

 

[Peter_SSs]

Does it really need to be vba?

If it does, then you could also try this:

Sub Departments()
  Dim a As Variant, b As Variant
  Dim i As Long
  
  With Sheets("Department").Range("A2", Sheets("Department").Range("B" & Rows.Count).End(xlUp))
    b = Application.Transpose(.Worksheet.Evaluate(.Columns(1).Address & "&""@ ""&" & .Columns(2).Address & "&"","""))
  End With
  With Sheets("Devices").Range("A2", Sheets("Devices").Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
    a = .Value
    For i = 1 To UBound(a)
      a(i, 2) = Join(Filter(Split(Join(Filter(b, " " & a(i, 1) & ","), "@"), "@"), ",", False), ", ")
    Next i
    .Value = a
  End With
End Sub

 

[CF64]

try this:

Sub test()
With Worksheets("Department")
 lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
 departlist = .Range(.Cells(1, 1), .Cells(lastrow, 2))
 End With
 
With Worksheets("Devices")
 lastd = .Cells(Rows.Count, "A").End(xlUp).Row
 devicelist = .Range(.Cells(1, 1), .Cells(lastd, 2))
  For i = 2 To lastd
  devicelist(i, 2) = "" ' iniialise to blank
    For j = 2 To lastrow
     If InStr(departlist(j, 2), devicelist(i, 1)) > 0 Then
      devicelist(i, 2) = devicelist(i, 2) & departlist(j, 1) & ","
     End If
    Next j
      strlen = Len(devicelist(i, 2))
     If strlen > 0 Then
     devicelist(i, 2) = Left(devicelist(i, 2), strlen - 1) ' remove trailing comma
     End If
  Next i
  .Range(.Cells(1, 1), .Cells(lastd, 2)) = devicelist
 End With
End Sub

Hello, Thank you. This works in my sample spreadsheet perfectly. When I try to use it in another worksheet set up the same way as my sample, I get a run-time error '13': Type mismatch. I've confirmed that all of the columns are formatted as general. I'm hoping you have some suggestions on how I might be able to fix. Thank you

In debug mode, this is the line - If InStr(departlist(j, 2), devicelist(i, 1)) > 0 Then

 

[Peter_SSs]

A number of other suggestions have been made. Have you tried any of those?

 

[offthelip]

Hello, Thank you. This works in my sample spreadsheet perfectly. When I try to use it in another worksheet set up the same way as my sample, I get a run-time error '13': Type mismatch. I've confirmed that all of the columns are formatted as general. I'm hoping you have some suggestions on how I might be able to fix. Thank you

In debug mode, this is the line - If InStr(departlist(j, 2), devicelist(i, 1)) > 0 Then

The possible cause of this is that one of your device ids is a number and not a string, this will cause the instr function to throw up an error. How you handle this depends on whether that is an error in your data ( which presumably you fix by changing the data) or whether the code needs to be modified deal with it. The other possibility is the the varianble LastD is not correctly identifying the last row on the spreadsheet.
I suggest you run the code a gain and when the error occurs hover your mouse over each of the variables to check values in : departlist, j, devicelist and i ,to find out what the values are and thus determine what the cause of the error is.

 

[Alex Blakenburg]

The possible cause of this is that one of your device ids is a number and not a string, this will cause the instr function to throw up an error.

Are you sure ? I can't get this to produce an error.
However if one of the ID contains an error ie contains #N/A or #REF! etc, that will generate a error 13 Type mismatch.

 

[offthelip]

@ Alex, You are absolutely correct when I tried it worked OK, I obviously don't know enough about mixing types!!