皆からの助けに感謝します。私はこれに精力的に取り組んでおり、多くのことを学びました。そのために書いたコードを共有したかったのです。使用したコードにコメント付きの参照をいくつか含めました。また、ご提案がありましたら、ぜひお聞かせください。
このコードは：
ユーザーが特定した原因値のディクショナリを作成して、原因となる値のディクショナリを作成し、CE-Nameが一致する原因値のディクショナリを作成します。
一致するCE名を持つSympを連結し、「ユーザーが特定した原因値」が一致する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：最終データ