Печать нескольких текстовых строк из одной ячейки

Question

В настоящее время я использую Office 2003 для создания календаря с кодами отделов, относящимися к определенным отделам. Каждое «событие» в расписании имеет свой собственный набор дептовых кодов, скрытых рядом с каждой датой, и я пытаюсь напечатать соответствующую строку (для каждого «события» может быть несколько кодов депт). Мне нужна помощь в этом.

Резюме

• каф кодов в колонке D, начиная со строки 10 (я быть переменная строка).

• Каждая ячейка, содержащая эти коды имеет буквы, разделенные запятыми (например, [M, A, P]) - и я хотел бы иметь возможность печатать несколько названий отделов на основе каждого из этих кодов отдела клеток)

• Мое намерение для переменной p состоит в том, чтобы найти место каждого кода отдела с целью использования vlookup.

• Все мои коды отделов и текстовые строки находятся в P3: Q11, с столбцом P, включая коды отдела, и столбцом Q, включая соответствующие названия/текстовые строки отдела.

• p установлен для увеличения на 3 раза за цикл, потому что я решил, что вам нужно будет прыгать 3 символа, чтобы найти следующий код отдела (запятая, пробел, новая буква).

• Я хотел бы напечатать соло/несколько текстовых строк (в зависимости от того, существует ли более одного кода dept для события) в той же строке, что и соответствующие коды, которые вы просматриваете, но в столбце K (в отличие от того, где коды DEPT расположены - колонка 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

Вот предложил мое решение, используя функцию Split и коллекцию.

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 

Позвольте мне знать, если вам нужно уточнение