Вы не просили решение VBA, но, казалось бы, его проще всего реализовать. Вы также не указали, каким образом вы хотите, чтобы ваши данные выводились, или как вы хотели иметь возможность выбрать задачу / недели для отображения.
Я предположил или выбрал следующее, все из которых можно изменить:
- Задачи и недели будут в столбцах А и С, как показано выше.
- Соответствующая задача будет выбрана из выпадающего списка, реализована путем проверки данных, и этот список задач будет отсортирован по алфавиту (отсортирован).
- Поскольку ваш список задач включает запятые, нам нужно создать список задач в виде диапазона ячеек на листе. Этот лист будет скрытым листом.
- Список будет выведен в окне сообщения
- Алгоритм позволяет дублировать задачи в столбце A
- Список возвращаемых недель критически зависит от объединенной области списка задач. Если вы когда-нибудь откроете ячейки, алгоритм нужно будет скорректировать.
- Список будет обновляться всякий раз, когда вы вносите изменения в список задач или изменяете выбранную задачу в раскрывающемся списке.
Код рабочего листа
Щелкните правой кнопкой мыши вкладку «Рабочий лист» и выберите « View Code
Option Explicit
Private Sub Worksheet_Activate()
Set rInput = Cells(1, 5)
Application.EnableEvents = False
ValidationList
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Set rInput = Cells(1, 5)
If Not Intersect(Target, Columns(1)) Is Nothing Then
Application.EnableEvents = False
ValidationList
Application.EnableEvents = True
End If
If Not Intersect(Target, rInput) Is Nothing Then DisplayWeeks
End Sub
Обычный модуль
Выберите Insert Module в строке меню редактора VB.
Option Explicit
Public rInput As Range
Sub ValidationList()
Dim colTasks As Collection
Dim vTasks() As Variant
Dim V1 As Variant, V2 As Variant
Dim I As Long
'Read the tasks into a variant array
V1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
'Collect the tasks, eliminate the blanks
'Remove Duplicate entries
Set colTasks = New Collection
On Error Resume Next
For Each V2 In V1
If V2 <> "" Then colTasks.Add V2, CStr(V2)
Next V2
On Error GoTo 0
'Read tasks into array
ReDim vTasks(1 To colTasks.Count)
For I = 1 To UBound(vTasks)
vTasks(I) = colTasks(I)
Next I
'Since tasks might contain a comma
' the list must be on a worksheet
'Create the worksheet if not present
' and hide it
Dim wsTasks As Worksheet
Dim rTasks As Range
On Error Resume Next
Set wsTasks = Worksheets("Tasks")
Select Case Err.Number
Case 9
Worksheets.Add
ActiveSheet.Name = "Tasks"
Set wsTasks = Worksheets("Tasks")
wsTasks.Visible = xlSheetHidden
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop 'for debugging
Exit Sub
End Select
On Error GoTo 0
Set rTasks = wsTasks.Cells(1, 1).Resize(1, UBound(vTasks))
rTasks = vTasks
'Sort the task list
rTasks.Sort key1:=rTasks.Rows(1), _
order1:=xlAscending, _
Header:=xlNo, _
MatchCase:=False, _
Orientation:=xlSortRows
'Create the Input Cell
With rInput
.Clear
With .Validation
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertInformation, _
Formula1:="=" & rTasks.Worksheet.Name & "!" & rTasks.Address(True, True)
.InCellDropdown = True
.InputMessage = "Select from Drop Down List"
.ShowInput = True
.ShowError = True
End With
.Style = "Input"
End With
End Sub
Выберите « Insert Module в строке меню редактора VB, чтобы вставить второй обычный модуль. Вы можете поместить оба в один и тот же модуль, но отладка может быть проще
Если вы поместите оба макроса в один и тот же модуль, удалите второй экземпляр Option Explicit
Option Explicit
Sub DisplayWeeks()
Dim colWeeks As Collection
Dim R1 As Range, R2 As Range, C As Range
Dim FirstAddress As String
Dim V As Variant, I As Long
Set colWeeks = New Collection
'Find the task(s)
If rInput = "" Then Exit Sub
With Columns(1)
Set R1 = .Find(what:=rInput, _
after:=.Cells(.Rows.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False)
If R1 Is Nothing Then
MsgBox "Something Wrong" & vbLf & """Find"" & did not work"
Stop
Exit Sub
End If
FirstAddress = R1.Address
Set R2 = R1.Offset(0, 2).Resize(rowsize:=R1.MergeArea.Rows.Count)
For Each C In R2
If C.Text <> "" Then colWeeks.Add C.Text
Next C
Do
Set R1 = .FindNext(R1)
If R1 Is Nothing Then Exit Do
If R1.Address <> FirstAddress Then
Set R2 = R1.Offset(0, 2).Resize(rowsize:=R1.MergeArea.Rows.Count)
For Each C In R2
If C.Text <> "" Then colWeeks.Add C.Text
Next C
End If
Loop Until R1.Address = FirstAddress
End With
ReDim V(1 To colWeeks.Count)
For I = 1 To UBound(V)
V(I) = CStr(colWeeks(I))
Next I
Application.Cursor = xlDefault
MsgBox "Weeks for this task:" & vbLf & Join(V, vbLf)
End Sub
