Ich weiß die Hilfe von allen zu schätzen, ich habe unermüdlich daran gearbeitet und viel gelernt, also wollte ich den Code, den ich dafür geschrieben habe, teilen. Ich habe ein paar Verweise in den Code aufgenommen, den ich verwendet habe. Auch wenn Sie weitere Vorschläge haben, würde ich sie gerne hören.
Dieser Code wird:
Erstellen Sie ein Wörterbuch mit benutzerdefinierten Ursachenwerten, auf die Sie achten müssen, und erstellen Sie ein Wörterbuch mit Ursachenwerten mit einem passenden CE-Namen.
Es verkettet das Symp, das einen übereinstimmenden CE-Namen hat, und identifiziert die verkettete Zelle durch Hervorheben, solange die "vom Benutzer identifizierten Ursachenwerte" nicht im Matching CE Cause Dictionary vorhanden sind
Die zusätzlichen Zeilen (unnötige Zeilen) werden als nicht zutreffend identifiziert
Es wird jede Zeile mit N / A entfernen
Die Daten werden dann nach identifizierten (farbigen) Zeilen sortiert
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
Bild 1: Rohdaten
Bild 2: Paare
Bild 3: Endgültige Daten