Я согласен с комментариями: это задача для VBA.
Я набрал твой GIF на листе. Я не пытался исправить то, что я считаю ошибками. Например, столбец A содержит «SEMS», а столбец D содержит «SMES».
Шаг 1 следующей процедуры состоит в том, чтобы обработать столбцы C и D, затем столбцы E и F и накапливать данные в массив структур. Цель состоит в том, чтобы изменить отношения, чтобы дать:
MSC Tech1 Tech2 ...
ATT Tech1 Tech2 ...
: :
В результате они помещаются в столбец B.
Первый шаг довольно сложный. Я надеюсь, что я включил достаточно комментариев, чтобы вы могли понять мой код. Работайте медленно и возвращайтесь с вопросами.
Option Explicit
' VBA as intrinsic data types : string, long, double, etc.
' You can declare an array of longs, say.
' The size of an array can be fixed when it is declared:
' Dim A(1 To 5) As Long
' or it can be declared as dynamic and then resized as necessary:
' Dim A() As Long
' ReDim A(1 to 5) ' Initialise A with five entries
' ReDim Preserve A(1 to 10) ' Preserve the first five entries in A
' ' and add another 5.
'
' Sometimes a more complex structure is required. For this problem we need
' to build a list of Tasks with a list of Competencies against each Task.
' VBA allows us to to define the necessary structure as a "User Type"
' Define a user type consisting of a Task name and an array of Competencies
Type typTaskComp
Task As String
Comp() As String
End Type
' Declare array in which Tasks and Competencies are
' accumulated as a dynamic array of type typTaskComp.
Dim TaskComp() As typTaskComp
Dim InxTaskCrntMax As Long
Sub MatchTaskToCompetencies()
Dim CompListCrnt As String
Dim InxCompCrnt As Long ' Index for Competencies for a Task
Dim InxTaskCrnt As Long ' Index for Tasks
Dim RowCrnt As Long
Dim TaskCrnt As String
ReDim TaskComp(1 To 10) ' Initialise TaskComp for 10 Tasks
InxTaskCrntMax = 0 ' The last currently used row in TaskComp. That
' is, no rows are currently used.
' Load array TaskComp() from the sheet
Call DecodeCompencyTask("Sheet1", 3, 4)
Call DecodeCompencyTask("Sheet1", 5, 6)
' The format and contents of TaskComp is now:
' Competency ...
' Task 1 2 3 4 5 ...
' 1 MSC Tech1 Tech2 Tech3 Tech4 PS1
' 2 ATT Tech1 Tech2 Tech3 Tech4 PS1
' 3 PLCY Tech1 Tech2 Tech4 Tech5 Tech6
' : :
' Display contents of TaskComp() to Immediate window
For InxTaskCrnt = 1 To InxTaskCrntMax
Debug.Print Left(TaskComp(InxTaskCrnt).Task & Space(5), 6);
For InxCompCrnt = 1 To UBound(TaskComp(InxTaskCrnt).Comp)
If TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = "" Then
Exit For
End If
Debug.Print Left(TaskComp(InxTaskCrnt).Comp(InxCompCrnt) & Space(5), 6);
Next
Debug.Print
Next
' Now place lists of Competencies in Column 2 against appropriate Task
RowCrnt = 2
With Worksheets("Sheet1")
TaskCrnt = .Cells(RowCrnt, 1).Value
Do While TaskCrnt <> ""
For InxTaskCrnt = 1 To InxTaskCrntMax
If TaskCrnt = TaskComp(InxTaskCrnt).Task Then
' Have found row in TaskComp that matches this row in worksheet
' Merge list of Competencies into a list separated by commas
CompListCrnt = Join(TaskComp(InxTaskCrnt).Comp, ",")
' Empty entries at the end of TaskComp(InxTaskCrnt).Comp will
' result in trailing commas. Remove them.
Do While Right(CompListCrnt, 1) = ","
CompListCrnt = Mid(CompListCrnt, 1, Len(CompListCrnt) - 1)
Loop
' and place in column 2
.Cells(RowCrnt, 2).Value = CompListCrnt
Exit For
End If
Next
RowCrnt = RowCrnt + 1
TaskCrnt = .Cells(RowCrnt, 1).Value
Loop
End With
End Sub
Sub DecodeCompencyTask(WShtName As String, ColComp As Long, ColTask As Long)
' Sheet WShtName contains two columns numbered ColComp and ColTask, Column
' ColComp contains one Competency per cell. Column ColTask holds a comma
' separated list of Tasks per cell. For each row, the Competency is gained
' by performing any of the Tasks.
' Scan the two columns. If a Task is missing from TaskComp() prepare a row
' for it. Add the Competency to the new or existing row for the Task.
Dim CompCrnt As String
Dim Found As Boolean
Dim InxCompCrnt As Long ' Index for Competencies for a Task
Dim InxTaskCrnt As Long ' Index for Tasks
Dim RowCrnt As Long
Dim TaskCrnt As Variant
Dim TaskList() As String
With Worksheets(WShtName)
RowCrnt = 2
Do While .Cells(RowCrnt, ColComp).Value <> ""
CompCrnt = .Cells(RowCrnt, ColComp).Value ' Extract Competency
' Remove any spaces from Task List and then split it
' so there is one Task per entry in TaskList.
TaskList = Split(Replace(.Cells(RowCrnt, ColTask).Value, " ", ""), ",")
' Process each task in TaskList
For Each TaskCrnt In TaskList
Found = False
' Look for current Task in existing rows
For InxTaskCrnt = 1 To InxTaskCrntMax
If TaskComp(InxTaskCrnt).Task = TaskCrnt Then
Found = True
Exit For
End If
Next
If Not Found Then
' New Task found. Prepare new row with Task but no
' Competencies
InxTaskCrntMax = InxTaskCrntMax + 1
If InxTaskCrntMax > UBound(TaskComp) Then
' No free rows in TaskComp. Add some more rows
ReDim Preserve TaskComp(1 To UBound(TaskComp) + 10)
End If
InxTaskCrnt = InxTaskCrntMax
TaskComp(InxTaskCrnt).Task = TaskCrnt
ReDim TaskComp(InxTaskCrnt).Comp(1 To 5)
' Rely on array entries being initialised to ""
End If
Found = False
' Look for an empty Competency slot in current row of TaskComp
For InxCompCrnt = 1 To UBound(TaskComp(InxTaskCrnt).Comp)
If TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = "" Then
Found = True
Exit For
End If
Next
If Not Found Then
' Row is full. Add some extra entries and set InxCompCrnt to
' first of these new entries.
InxCompCrnt = 1 + UBound(TaskComp(InxTaskCrnt).Comp)
ReDim Preserve TaskComp(InxTaskCrnt).Comp(1 _
To UBound(TaskComp(InxCompCrnt).Comp) + 5)
End If
TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = CompCrnt
InxCompCrnt = InxCompCrnt + 1
Next
RowCrnt = RowCrnt + 1
Loop
End With
End Sub