VBA-Code zum Verketten von Zellen basierend auf Werten in anderen Spalten

Dies ist eine tägliche Aufgabe von mir, bei der ich Rohdaten wie in Bild 1 dargestellt aufnehmen und die Daten sortieren muss. Normalerweise umfasst das zu untersuchende Datenmuster etwa 2000 Werbebuchungen.

Ich möchte dies so gut wie möglich optimieren, um meinen Prozess in Schritte aufzuteilen.

1. Ich sortiere die Daten nach Spalte E ("CE Name"),
2. Ich formatiere bedingt und für Duplikate in Spalte A (Produktserie) und Spalte E ("CE-Name"),
3. Ich suche nach Werten ungleich "L101" in Spalte G ("Ursachencode") (ich hebe sie für visuelle Zwecke hervor),

4. (Der schwierige Schritt) Wenn die Werte in Spalte E ("CE-Name") gleich sind und die Werte in Spalte G ("Ursachencode") ungleich "L101" sind, trenne ich diese Werte.

   Hinweis: Dadurch werden zwei Beispieldatensätze erstellt

   Datenbeispiel 1: Ein Satz oder eine einzelne Zeile mit einem "L101" -Wert in Spalte G ("Ursachencode").

   Datenbeispiel 2: Ein Satz oder eine einzelne Zeile, die keinen "L101" -Wert in Spalte G ("Ursachencode") enthält.
   
   

   Bsp .: 1 Zeile 4 und 5 von Bild 1, "C-375204", enthält 2 Spalten-G-Werte ("Ursachencode") ungleich L101. Dies wird zu einem "Datenmuster 2".

   Bsp .: 2 Zeile 8 und 9 von Bild 1, "C-375306" enthält die Werte für Spalte G ("Ursachencode") von "L101" und "L208". Da ein Wert für "L101" vorhanden ist, handelt es sich um ein "Datenmuster" 1 ".

   Bsp .: 3 Zeile 12 und 13 von Bild 1, "C-376157", enthält 2 Spalten-G-Werte ("Cause Code") von "L101". Dies wird zu "Datenprobe 1".

5. Sobald alle Daten sortiert sind, verknüpfe ich die Werte in Spalte B ("Symp") mit den durch Kommas (",") getrennten Werten in Spalte E ("CE-Name").

   Bsp .: Zeile 4 und 5 von Bild 1, "C-375204", Spalte B ("Symp") wird als "LM01, LM01" als Bild in Bild 3, Zeile 24 angezeigt.
   

6. Entfernen Sie zusätzliche Daten, um das in Bild 3 gezeigte Endprodukt zu beenden.

Bild 1: Rohdaten

Bild 2: Paare

Bild 3: Endgültige Daten

Ich hatte nicht genug Zeit, um es zu verbessern, und es gibt einige Abkürzungen, aber dies sollte etwas in der Art tun, wie Sie es wünschen.

Dieser Code erwartet, dass sich Ihre Tabelle in der oberen linken Ecke des Arbeitsblatts befindet, in dem Sie das Makro ausführen. Es werden zwei neue Arbeitsblätter erstellt und die Daten dort abgelegt.

Sub Sort()

Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing

'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
    Sheets.Add(After:=ActiveSheet).name = "Data 1"
    Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If

For Each obj In nameRange
    'Make Group
    If savedRange Is Nothing Then
            Set savedRange = Range(obj.Address)
            Set firstRange = Range(obj.Address)
    Else
            Set savedRange = Range(savedRange.Address, obj.Address)
    End If

    'Print Group
    If Not obj.Offset(1).Value = obj.Value Then
        If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
            'Data range 1
            Rows(firstRange.Row).Copy
            Sheets("Data 1").Range("A1").Insert
            Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
        Else
            'Data Range 2
            Rows(firstRange.Row).Copy
            Sheets("Data 2").Range("A1").Insert
            Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
        End If
        'reset group
        Set savedRange = Nothing
    End If

Next obj


End Sub

Function ConcatenateRow(rowRange As Range, joinString As String) As String
    Dim x As Variant, temp As String

    temp = ""
    For Each x In rowRange
        temp = temp & x & joinString
    Next

    ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function

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