Printing multiple text strings from single cell

Question

I'm currently using Office 2003 to create a calendar with department codes relating to certain departments. Each "event" on the schedule has its own set of dept codes hidden next to each date, and I am trying to print the corresponding string (there can be multiple dept codes for each "event"). I need help to do this.

Summary

• The dept codes are in column D, starting at row 10 (i being the row variable).

• Each cell that contains these codes has letters separated by commas (ex [M, A, P]) - and I would like to be able to print multiple department names based on each of these department code cells)

• My intention for variable p is to find the place of each department code with the intention of using a vlookup.

• All of my department codes and text strings are found in P3:Q11, with column P including the department codes, and column Q including the corresponding department names/ text strings.

• p is set to increase by 3 times per loop, because I figured you would need to jump 3 characters to find the next possible department code (comma, space, new letter).

• I would like to print the solo/multiple text strings (depending on whether there is more than one dept code for the event) in the same row as the respective codes you are looking up are found, but in column K (as opposed to where the dept codes are located - column D)

---

Sub DepartmentNames()

Dim i As Long

Dim p As Integer

Dim LastRow As Long

LastRow = Range("D" & Rows.Count).End(xlUp).Row

For i = 10 To LastRow

    For p = 1 To Len("D" & i) Step 3

        ' Placeholder

    Next

Next i

End Sub

Answer 1

Here is my proposed solution, using the Split function and a collection.

Sub Reference()

' Disable screen updating
Application.ScreenUpdating = False

Dim wS As Worksheet
Set wS = ActiveSheet   ' you can change it to be a specific sheet

Dim i As Long
Dim LastRow As Long
LastRow = Range("D" & Rows.Count).End(xlUp).Row


Dim Dpts As Variant
Dim dFullText As Variant
Dim LookUp As New Collection

' Create a collection where the key is the shortcode and the value is the full name of the dpt
On Error Resume Next
For i = 3 To 11

    LookUp.Add wS.Cells(i, 17), wS.Cells(i, 16)

Next i
On Error GoTo 0


' Loop on each row
For i = 10 To LastRow

    Dpts = Split(wS.Cells(i, 4), ",") ' Split creates an array

    ' First case
    dFullText = LookUp.Item(Trim(Dpts(0)))   ' TRIM = remove trailing and leading spaces

    ' The rest of them
    For j = 1 To UBound(Dpts)

        dFullText = dFullText & ", " & LookUp.Item(Trim(Dpts(j)))

    Next j

    ' Put full text in column K
    wS.Cells(i, 11).Value = dFullText

Next i

' Enable screen updating again
Application.ScreenUpdating = True

End Sub

Let me know if you need clarification