Csdrhrt

This is a daily task of mine where I have to take raw data as pictured in Image 1 and I have to sort the data. Usually the data sample I have to go through is around 2000 line items.

I would like to stream line this as best as possible so I want to break down my process into steps.

1. I sort the data by Column E ("CE Name"),


2. I conditionally format and for duplicates in Column A (Product Serial) and Column E ("CE Name"),


3. I look for values not equal to "L101" in Column G ("Cause Code") (I highlight them for visual purposes),


4. 
   

   (The Difficult Step) If Column E ("CE Name") values are the same and Column G ("Cause Code") values are not equal to "L101" I separate those values.

   
   
   

   Note: this will make two sample data sets

   
   
   

   Data sample 1: will be any set or single row that includes an "L101" Value in Column G ("Cause Code").

   
   
   

   Data sample 2: will be any set or single row that does not includes an "L101" Value in Column G ("Cause Code").
   
   
   

   
   
   

   
   

   EX:1 Row 4 and 5 of Image 1, "C-375204" has 2 Column G ("Cause Code") values not equal to L101. This will become a "Data sample 2".

   
   
   

   EX:2 Row 8 and 9 of image 1, "C-375306" has Column G ("Cause Code") values of "L101" and "L208" Since there is an "L101" value present it will become a "Data sample 1".

   
   
   

   EX:3 Row 12 and 13 of image 1, "C-376157" has 2 Column G ("Cause Code") values of "L101" This will become a "Data sample 1".

   
   

   
   


5. 
   

   Once all data is sorted I concatenate the values in Column B ("Symp") based one the Column E ("CE Name") values separated by commas (",").

   
   
   

   
   

   EX: Row 4 and 5 of Image 1, "C-375204" will Column B ("Symp") appear as "LM01, LM01" as picture in Image 3 row 24.
   

   
   

   
   



6. Remove extra data to end it final product pictured in Image 3.

Image 1: Raw Data

Image 2: Pairs

Image 3: Final Data

I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.

This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.

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

I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.

This Code will:

Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.

It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary

It will identify the extra (unnecessary Rows) Rows as N/A

It will remove any row with N/A

It will then sort the data by Identified (Colored) Rows

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