Я ценю помощь всех, я неустанно работал над этим и многому научился, поэтому я хотел поделиться кодом, который я написал для этого. Я включил несколько ссылок, прокомментированных в коде, который я использовал. Кроме того, если у вас есть какие-либо дополнительные предложения, я хотел бы услышать их.
Этот Кодекс будет:
Создайте словарь идентифицированных пользователем причин, по которым нужно искать значения, и создайте словарь значений причин с соответствующим CE-именем.
Он объединит Symp, который имеет совпадающее имя CE, и идентифицирует объединенную ячейку, выделив ее, пока «Значения причины, определенные пользователем» отсутствуют в Словаре причин соответствия CE
Он идентифицирует дополнительные (ненужные строки) как N/A
Это удалит любую строку с N/A
Затем данные будут отсортированы по идентифицированным (цветным) строкам.
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Изображение 1: необработанные данные
Изображение 2: Пары
Изображение 3: Окончательные данные