asked on

Excel macro to group continuous alphanumeric terms in single cells

On a per cell basis, the contents need to be arranged alphanumerically and then continuous ones need to be grouped into <first term>-<last term> and all comma-space seperated.

Example:
C3506,C3508,C3509,C3510,C3511,C3536,C3537,C3538,C3539,C4120,C4121,C4620,C4621

Would become:
C3506, C3508-C3511, C3536-C3539, C4120, C4121, C4620, C4621,

Rules: Non-continuous remain so, 2 continuous remain so and 3+ continuous are grouped. The cells may come comma-no-space or comma-space and need to be sorted into comma-space.

And a check for duplicates in all cells would be a great bonus!

I've attached a dataset.

TIA,

Tim
REFDESSort.xlsx

Jacques Geday

we are talking of Col B obviously right ?gowflow

gibneyt

ASKER

gowflow,

Yes, that is correct.

Tim.

nutsch

Try this code, including Patrick Matthew's regexp function

Option Explicit

Sub asdgag()
Dim shtTemp As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lRowLoop As Long, arrCode, lLoop As Long
Dim lLastRow2 As Long, lRowLoop2 As Long
Dim lLastRow3 As Long, lRowLoop3 As Long
Dim sFirstValue As String, lDestRow As Long, sLastValue As String
Dim sResults As String

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Set shtOrg = ActiveSheet

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set shtTemp = Sheets.Add

For lRowLoop = 1 To lLastRow
    If InStr(shtOrg.Cells(lRowLoop, 2), ",") > 0 Then
        shtTemp.Cells.ClearContents
        arrCode = Split(shtOrg.Cells(lRowLoop, 2), ",")
        
        For lLoop = LBound(arrCode) To UBound(arrCode)
            shtTemp.Cells(1 + lLoop, 1) = arrCode(lLoop)
        Next
        
        With shtTemp
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("A1"), Header:=xlNo
        
            lLastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
            lDestRow = 1
        
    
            For lRowLoop2 = 1 To lLastRow2
                
                If lRowLoop2 = lLastRow2 Then GoTo lCloseLine:
                
                If RegExpFind(.Cells(lRowLoop2 + 1, 1), "[A-Z]+", 1) = RegExpFind(.Cells(lRowLoop2, 1), "[A-Z]+", 1) _
                    And CDbl(RegExpFind(.Cells(lRowLoop2 + 1, 1), "[0-9]+", 1)) = 1 + CDbl(RegExpFind(.Cells(lRowLoop2, 1), "[0-9]+", 1)) Then
                    If Len(sFirstValue) > 0 Then
                        sLastValue = .Cells(lRowLoop2 + 1, 1)
                    Else
                        sFirstValue = .Cells(lRowLoop2, 1)
                        sLastValue = .Cells(lRowLoop2 + 1, 1)
                    End If
                    GoTo lNextLine:
                
                End If
                
lCloseLine:
                If Len(sFirstValue) > 0 And Len(sLastValue) > 0 Then
                    .Cells(lDestRow, 2) = sFirstValue & "-" & sLastValue
                    sFirstValue = ""
                    sLastValue = ""
                Else
                    .Cells(lDestRow, 2) = .Cells(lRowLoop2, 1).Value
                End If
                
                lDestRow = lDestRow + 1

lNextLine:
            Next
        
            lLastRow3 = .Cells(Rows.Count, 2).End(xlUp).Row
            
            For lRowLoop3 = 1 To lLastRow3
                sResults = sResults & "," & .Cells(lRowLoop3, 2)
            Next
            
            shtOrg.Cells(lRowLoop, 2) = Mid(sResults, 2)
            sResults = ""
        End With
        
        Set arrCode = Nothing
    End If
    
    
    
Next lRowLoop
     
shtTemp.Delete


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
    Optional MatchCase As Boolean = True, Optional ReturnType As Long = 0, _
    Optional MultiLine As Boolean = False)
    
    ' Function written by Patrick G. Matthews.  You may use and distribute this code freely,
    ' as long as you properly credit and attribute authorship and the URL of where you
    ' found the code
    
    ' This function relies on the VBScript version of Regular Expressions, and thus some of
    ' the functionality available in Perl and/or .Net may not be available.  The full extent
    ' of what functionality will be available on any given computer is based on which version
    ' of the VBScript runtime is installed on that computer
    
    ' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
    ' pattern (PatternStr).  Use Pos to indicate which match you want:
    ' Pos omitted               : function returns a zero-based array of all matches
    ' Pos = 1                   : the first match
    ' Pos = 2                   : the second match
    ' Pos = <positive integer>  : the Nth match
    ' Pos = 0                   : the last match
    ' Pos = -1                  : the last match
    ' Pos = -2                  : the 2nd to last match
    ' Pos = <negative integer>  : the Nth to last match
    ' If Pos is non-numeric, or if the absolute value of Pos is greater than the number of
    ' matches, the function returns an empty string.  If no match is found, the function returns
    ' an empty string.  (Earlier versions of this code used zero for the last match; this is
    ' retained for backward compatibility)
    
    ' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
    ' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).
    
    ' ReturnType indicates what information you want to return:
    ' ReturnType = 0            : the matched values
    ' ReturnType = 1            : the starting character positions for the matched values
    ' ReturnType = 2            : the lengths of the matched values
    
    ' If MultiLine = False, the ^ and $ match the beginning and end of input, respectively.  If
    ' MultiLine = True, then ^ and $ match the beginning and end of each line (as demarcated by
    ' new line characters) in the input string
    
    ' If you use this function in Excel, you can use range references for any of the arguments.
    ' If you use this in Excel and return the full array, make sure to set up the formula as an
    ' array formula.  If you need the array formula to go down a column, use TRANSPOSE()
    
    ' Note: RegExp counts the character positions for the Match.FirstIndex property as starting
    ' at zero.  Since VB6 and VBA has strings starting at position 1, I have added one to make
    ' the character positions conform to VBA/VB6 expectations
    
    ' Normally as an object variable I would set the RegX variable to Nothing; however, in cases
    ' where a large number of calls to this function are made, making RegX a static variable that
    ' preserves its state in between calls significantly improves performance
    
    Static RegX As Object
    Dim TheMatches As Object
    Dim Answer()
    Dim Counter As Long
    
    ' Evaluate Pos.  If it is there, it must be numeric and converted to Long
    
    If Not IsMissing(Pos) Then
        If Not IsNumeric(Pos) Then
            RegExpFind = ""
            Exit Function
        Else
            Pos = CLng(Pos)
        End If
    End If
    
    ' Evaluate ReturnType
    
    If ReturnType < 0 Or ReturnType > 2 Then
        RegExpFind = ""
        Exit Function
    End If
    
    ' Create instance of RegExp object if needed, and set properties
    
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = True
        .IgnoreCase = Not MatchCase
        .MultiLine = MultiLine
    End With
        
    ' Test to see if there are any matches
    
    If RegX.Test(LookIn) Then
        
        ' Run RegExp to get the matches, which are returned as a zero-based collection
        
        Set TheMatches = RegX.Execute(LookIn)
        
        ' Test to see if Pos is negative, which indicates the user wants the Nth to last
        ' match.  If it is, then based on the number of matches convert Pos to a positive
        ' number, or zero for the last match
        
        If Not IsMissing(Pos) Then
            If Pos < 0 Then
                If Pos = -1 Then
                    Pos = 0
                Else
                    
                    ' If Abs(Pos) > number of matches, then the Nth to last match does not
                    ' exist.  Return a zero-length string
                    
                    If Abs(Pos) <= TheMatches.Count Then
                        Pos = TheMatches.Count + Pos + 1
                    Else
                        RegExpFind = ""
                        GoTo Cleanup
                    End If
                End If
            End If
        End If
        
        ' If Pos is missing, user wants array of all matches.  Build it and assign it as the
        ' function's return value
        
        If IsMissing(Pos) Then
            ReDim Answer(0 To TheMatches.Count - 1)
            For Counter = 0 To UBound(Answer)
                Select Case ReturnType
                    Case 0: Answer(Counter) = TheMatches(Counter)
                    Case 1: Answer(Counter) = TheMatches(Counter).FirstIndex + 1
                    Case 2: Answer(Counter) = TheMatches(Counter).Length
                End Select
            Next
            RegExpFind = Answer
        
        ' User wanted the Nth match (or last match, if Pos = 0).  Get the Nth value, if possible
        
        Else
            Select Case Pos
                Case 0                          ' Last match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(TheMatches.Count - 1)
                        Case 1: RegExpFind = TheMatches(TheMatches.Count - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(TheMatches.Count - 1).Length
                    End Select
                Case 1 To TheMatches.Count      ' Nth match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(Pos - 1)
                        Case 1: RegExpFind = TheMatches(Pos - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(Pos - 1).Length
                    End Select
                Case Else                       ' Invalid item number
                    RegExpFind = ""
            End Select
        End If
    
    ' If there are no matches, return empty string
    
    Else
        RegExpFind = ""
    End If
    
Cleanup:
    ' Release object variables
    
    Set TheMatches = Nothing
    
End Function

Open in new window

gibneyt

ASKER

gowflow,

Thank you very much for the code.

I created the asdgag macro and saved as .xlsm. This macro will need to have the refdes in column b always, correct? And it will do nothing to other columns? And I should bring data into the workbook without headers correct?

The second rule is not followed; two consecutive terms should remain as they are. Is that easy to fix?

I also noticed sorting is off. Line 32 original is:

D100,D500,D1506,D1507,D2503,D2504,D4000,D4500,D5000,D5002

after the macro it is:

D100,D1506-D1507,D2503-D2504,D4000,D4500,D500,D5000,D5002

but should be unchanged except for added spaces after the commas:

D100, D500, D1506, D1507, D2503, D2504, D4000, D4500, D5000, D5002.

And line 57 is:

U101,U105,U501,U505,U1009,U1010,U1505,U1506,U1507,U1513,U1514,U1515

and after the macro it is:

U1009,U101,U1010,U105,U1505-U1507,U1513-U1515,U501,U505

but should be:

U101, U105, U501, U505, U1009, U1010,U1505-U1507, U1513-U1515

And keeping column C Part Number is imperative for reference.

Thanks again.

Tim

nutsch

Try this update

Thomas

Option Explicit

Sub asdgag()
Dim shtTemp As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lRowLoop As Long, arrCode, lLoop As Long
Dim lLastRow2 As Long, lRowLoop2 As Long
Dim lLastRow3 As Long, lRowLoop3 As Long
Dim sFirstValue As String, lDestRow As Long, sLastValue As String
Dim sResults As String

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Set shtOrg = ActiveSheet

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set shtTemp = Sheets.Add

For lRowLoop = 1 To lLastRow
    If InStr(shtOrg.Cells(lRowLoop, 2), ",") > 0 Then
        shtTemp.Cells.ClearContents
        arrCode = Split(shtOrg.Cells(lRowLoop, 2), ",")
        
        For lLoop = LBound(arrCode) To UBound(arrCode)
            shtTemp.Cells(1 + lLoop, 1) = arrCode(lLoop)
        Next
        
        With shtTemp
        
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy .[b1]
            .Columns("B").Replace What:=RegExpFind(.[a1], "[A-Z]+", 1), Replacement:="", LookAt:=xlPart, _
                        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                        ReplaceFormat:=False
                        
            .Range("$A$1:$B$" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("B1"), Header:=xlNo
            .Columns("B").ClearContents
            lLastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
            lDestRow = 1
        
    
            For lRowLoop2 = 1 To lLastRow2
                
                If lRowLoop2 >= lLastRow2 Then GoTo lCloseLine:
                
                If RegExpFind(.Cells(lRowLoop2 + 1, 1), "[A-Z]+", 1) = RegExpFind(.Cells(lRowLoop2, 1), "[A-Z]+", 1) _
                    And CDbl(RegExpFind(.Cells(lRowLoop2 + 1, 1), "[0-9]+", 1)) = 1 + CDbl(RegExpFind(.Cells(lRowLoop2, 1), "[0-9]+", 1)) Then
                    If Len(sFirstValue) > 0 Then
                        sLastValue = .Cells(lRowLoop2 + 1, 1)
                    Else
                        If lRowLoop2 = lLastRow2 - 1 Then GoTo lCloseLine
                        If RegExpFind(.Cells(lRowLoop2 + 2, 1), "[A-Z]+", 1) = RegExpFind(.Cells(lRowLoop2, 1), "[A-Z]+", 1) _
                            And CDbl(RegExpFind(.Cells(lRowLoop2 + 2, 1), "[0-9]+", 1)) = 2 + CDbl(RegExpFind(.Cells(lRowLoop2, 1), "[0-9]+", 1)) Then
                                sFirstValue = .Cells(lRowLoop2, 1)
                                sLastValue = .Cells(lRowLoop2 + 1, 1)
                        Else
                            GoTo lCloseLine
                        End If
                    End If
                    GoTo lNextLine:
                
                End If
                
lCloseLine:
                If Len(sFirstValue) > 0 And Len(sLastValue) > 0 Then
                    .Cells(lDestRow, 2) = sFirstValue & "-" & sLastValue
                    sFirstValue = ""
                    sLastValue = ""
                Else
                    .Cells(lDestRow, 2) = .Cells(lRowLoop2, 1).Value
                End If
                
                lDestRow = lDestRow + 1

lNextLine:
            Next
        
            lLastRow3 = .Cells(Rows.Count, 2).End(xlUp).Row
            
            For lRowLoop3 = 1 To lLastRow3
                sResults = sResults & ", " & .Cells(lRowLoop3, 2)
            Next
            
            shtOrg.Cells(lRowLoop, 2) = Mid(sResults, 3)
            sResults = ""
        End With
        
        Set arrCode = Nothing
    End If
    
    
    
Next lRowLoop
     
shtTemp.Delete


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
    Optional MatchCase As Boolean = True, Optional ReturnType As Long = 0, _
    Optional MultiLine As Boolean = False)
    
    ' Function written by Patrick G. Matthews.  You may use and distribute this code freely,
    ' as long as you properly credit and attribute authorship and the URL of where you
    ' found the code
    
    ' This function relies on the VBScript version of Regular Expressions, and thus some of
    ' the functionality available in Perl and/or .Net may not be available.  The full extent
    ' of what functionality will be available on any given computer is based on which version
    ' of the VBScript runtime is installed on that computer
    
    ' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
    ' pattern (PatternStr).  Use Pos to indicate which match you want:
    ' Pos omitted               : function returns a zero-based array of all matches
    ' Pos = 1                   : the first match
    ' Pos = 2                   : the second match
    ' Pos = <positive integer>  : the Nth match
    ' Pos = 0                   : the last match
    ' Pos = -1                  : the last match
    ' Pos = -2                  : the 2nd to last match
    ' Pos = <negative integer>  : the Nth to last match
    ' If Pos is non-numeric, or if the absolute value of Pos is greater than the number of
    ' matches, the function returns an empty string.  If no match is found, the function returns
    ' an empty string.  (Earlier versions of this code used zero for the last match; this is
    ' retained for backward compatibility)
    
    ' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
    ' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).
    
    ' ReturnType indicates what information you want to return:
    ' ReturnType = 0            : the matched values
    ' ReturnType = 1            : the starting character positions for the matched values
    ' ReturnType = 2            : the lengths of the matched values
    
    ' If MultiLine = False, the ^ and $ match the beginning and end of input, respectively.  If
    ' MultiLine = True, then ^ and $ match the beginning and end of each line (as demarcated by
    ' new line characters) in the input string
    
    ' If you use this function in Excel, you can use range references for any of the arguments.
    ' If you use this in Excel and return the full array, make sure to set up the formula as an
    ' array formula.  If you need the array formula to go down a column, use TRANSPOSE()
    
    ' Note: RegExp counts the character positions for the Match.FirstIndex property as starting
    ' at zero.  Since VB6 and VBA has strings starting at position 1, I have added one to make
    ' the character positions conform to VBA/VB6 expectations
    
    ' Normally as an object variable I would set the RegX variable to Nothing; however, in cases
    ' where a large number of calls to this function are made, making RegX a static variable that
    ' preserves its state in between calls significantly improves performance
    
    Static RegX As Object
    Dim TheMatches As Object
    Dim Answer()
    Dim Counter As Long
    
    ' Evaluate Pos.  If it is there, it must be numeric and converted to Long
    
    If Not IsMissing(Pos) Then
        If Not IsNumeric(Pos) Then
            RegExpFind = ""
            Exit Function
        Else
            Pos = CLng(Pos)
        End If
    End If
    
    ' Evaluate ReturnType
    
    If ReturnType < 0 Or ReturnType > 2 Then
        RegExpFind = ""
        Exit Function
    End If
    
    ' Create instance of RegExp object if needed, and set properties
    
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = True
        .IgnoreCase = Not MatchCase
        .MultiLine = MultiLine
    End With
        
    ' Test to see if there are any matches
    
    If RegX.Test(LookIn) Then
        
        ' Run RegExp to get the matches, which are returned as a zero-based collection
        
        Set TheMatches = RegX.Execute(LookIn)
        
        ' Test to see if Pos is negative, which indicates the user wants the Nth to last
        ' match.  If it is, then based on the number of matches convert Pos to a positive
        ' number, or zero for the last match
        
        If Not IsMissing(Pos) Then
            If Pos < 0 Then
                If Pos = -1 Then
                    Pos = 0
                Else
                    
                    ' If Abs(Pos) > number of matches, then the Nth to last match does not
                    ' exist.  Return a zero-length string
                    
                    If Abs(Pos) <= TheMatches.Count Then
                        Pos = TheMatches.Count + Pos + 1
                    Else
                        RegExpFind = ""
                        GoTo Cleanup
                    End If
                End If
            End If
        End If
        
        ' If Pos is missing, user wants array of all matches.  Build it and assign it as the
        ' function's return value
        
        If IsMissing(Pos) Then
            ReDim Answer(0 To TheMatches.Count - 1)
            For Counter = 0 To UBound(Answer)
                Select Case ReturnType
                    Case 0: Answer(Counter) = TheMatches(Counter)
                    Case 1: Answer(Counter) = TheMatches(Counter).FirstIndex + 1
                    Case 2: Answer(Counter) = TheMatches(Counter).Length
                End Select
            Next
            RegExpFind = Answer
        
        ' User wanted the Nth match (or last match, if Pos = 0).  Get the Nth value, if possible
        
        Else
            Select Case Pos
                Case 0                          ' Last match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(TheMatches.Count - 1)
                        Case 1: RegExpFind = TheMatches(TheMatches.Count - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(TheMatches.Count - 1).Length
                    End Select
                Case 1 To TheMatches.Count      ' Nth match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(Pos - 1)
                        Case 1: RegExpFind = TheMatches(Pos - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(Pos - 1).Length
                    End Select
                Case Else                       ' Invalid item number
                    RegExpFind = ""
            End Select
        End If
    
    ' If there are no matches, return empty string
    
    Else
        RegExpFind = ""
    End If
    
Cleanup:
    ' Release object variables
    
    Set TheMatches = Nothing
    
End Function

Open in new window

gibneyt

ASKER

nutsh,

Yes that works perfectly as far as I can see. Thank you so much!

One problem I did not notice in my data. There are three part numbers that have multiple rows. Can those be aggregated/combined into one row?

Parts 7000280, 7000461, and 7001316.

The quantities would have to be added too.

This could happen in any incoming data set apparently.

I've just noticed i was confused on my previous post on who was answering. Thanks nutsh.

Tim

Jacques Geday

ok here I am ...

I worked hard on it but was able to get it thru only now !!!

Please try this file make sure your macroes are enabled and just activate the button on the sheet. It will create a new sheet and keep the original so you can check the data to make sure all is fine. The sheet is created with a time stamp so you can run it several times ...

Please chek it and let me know.

gowflow
REFDESSort.xlsm

gibneyt

ASKER

gowflow,

Thanks very much for your time. I can't get past Option Explicit! Much less what you have done!

One issue, otherwise the sort looks perfect: There are 3 parts with multiple rows, 7000280, 7000461, and 7001316. They are grouped and sorted within their original cells but once copied to their new cell they remain in that sort order are not combined and sorted within that cell.

Thanks again,

Tim

ASKER CERTIFIED SOLUTION

nutsch

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Jacques Geday

What do you mean by

One issue, otherwise the sort looks perfect: There are 3 parts with multiple rows, 7000280, 7000461, and 7001316. They are grouped and sorted within their original cells but once copied to their new cell they remain in that sort order are not combined and sorted within that cell.

The file I posted above will combine all similar rows that have the same Reference into 1 line and will arrange the codes as per your requirement.

What do you mean you did not pass Option Explicit ???? The code is in a module and has to stay like this if you want you can move your sheet into this workbook and run the macro called
SortNGroup

Let me know
gowflow

Jacques Geday

If you are not able to run my code then here it is:

Sub SortNGroup()
Dim WS As Worksheet
Dim MaxRow As Long, I As Long, J As Long, K As Long
Dim MaxRowZY As Long
Dim Items, Item
Dim FMItem As String, TOItem As String, TO1Item As String
Dim LCount As Long, Ones As Long
Dim ExitLoop As Boolean
Dim PartNum As String

Set WS = ActiveSheet
WS.Copy after:=ActiveWorkbook.Worksheets(Sheets.Count)
Set WS = ActiveSheet
WS.Name = "Grouped " & Format(Now, "dd-mmm-yy hhmm")

MaxRow = WS.UsedRange.Rows.Count

'---> Sort the Sheet Per Column C to make sure that all same rows in C folllows
WS.Range("A2").Sort Key1:=WS.Columns(3), order1:=xlAscending, MatchCase:=True, Header:=xlYes

'---> Group Same Items in C in 1 row
J = 2
PartNum = WS.Range("C" & J)
For I = 2 To MaxRow
    If PartNum = WS.Range("C" & I) And WS.Range("C" & I) <> "" And I <> J Then
        WS.Range("A" & J) = WS.Range("A" & J) + WS.Range("A" & I)
        WS.Range("B" & J) = WS.Range("B" & J) & "," & WS.Range("B" & I)
        PartNum = WS.Range("C" & I)
        WS.Range("A" & I & ":C" & I).ClearContents
    Else
        PartNum = WS.Range("C" & I)
        J = I
    End If

Next I

'---> Sort the Sheet Per Column C Again after the grouping
WS.UsedRange.Sort Key1:=WS.Columns(3), order1:=xlAscending, MatchCase:=True, Header:=xlYes
MaxRow = WS.UsedRange.Rows.Count


For I = 2 To MaxRow
    '---> Get Col B in Array
    Items = Split(WS.Cells(I, "B"), ",")
    
    '---> Get the Array in Cells for better handling starting ZY1 ...
    WS.Range("ZX:ZZ").Clear
    For J = 0 To UBound(Items)
        WS.Cells(J + 1, "ZX") = Items(J)
        K = 1
        Do
            K = K + 1
        Loop Until IsNumeric(Mid(Items(J), K, 1))
        WS.Cells(J + 1, "ZY") = Mid(Items(J), K)
    Next J
    
    MaxRowZY = WS.Cells(I, "A")
    
    WS.Range("ZZ1").Formula = "=$ZY1"
    If MaxRowZY > 1 Then
        WS.Range("ZZ1").Formula = "=$ZY2-$ZY1"
        WS.Range("ZZ2:ZZ" & MaxRowZY).Formula = "=IF(AND($ZY3-$ZY2=1,$ZY2-$ZY1=1),1,IF($ZY2-$ZY1=1,1,IF($ZY3-$ZY2=1,0,$ZY2)))"
    End If
    
    '---> Group the Items into a string
    FMItem = ""
    TOItem = ""
    Item = ""
    
    If I = 24 Or I = 33 Then
        a = 1
    End If
        
    For J = 1 To MaxRowZY + 1
        
        
        '---> Locate if there is a 1 down
        K = J
        Ones = 0
        ExitLoop = False
        Do While (WS.Cells(K, "ZZ") = 1 Or WS.Cells(K, "ZZ") = 0) And WS.Cells(K, "ZZ") <> ""
            If ExitLoop Then Exit Do
            Ones = Ones + 1
            K = K + 1
            If WS.Cells(K, "ZZ") = 0 Then ExitLoop = True
        Loop
        
        '---> New Way
        If Ones > 2 Then
            FMItem = WS.Cells(J, "ZX")
            TOItem = WS.Cells(K - 1, "ZX")
            If Item <> "" Then Item = Item & ", "
            Item = Item & FMItem & "-" & TOItem
            J = K - 1
            LCount = LCount + 2
        Else
            If Item <> "" Then Item = Item & ", "
            Item = Item & WS.Cells(J, "ZX")
            LCount = LCount + 1
        End If
        
    Next J

    WS.Cells(I, "B") = Item
Next I

WS.Range("ZX:ZZ").Clear
MsgBox ("Sorting and Grouping have been performed successfully for " & LCount & " Items in Column B")

End Sub

Open in new window

You should run it being in the data sheet. Like select the sheet that have the data then choose Developper/Macroes and Select SortNGroup.

You can copy this macro in a Module in your workbook.

gowflow

gibneyt

ASKER

gowflow

What I meant after saying "Thank you" and referring to "Option Explicit" is that I wish I could code this stuff like you! A complement :-)

The code runs just fine.

As for the results let's look at part number 7001316 with two original rows. The two rows of reference designators are:

F100,F101,F102,F103,F104,F105,F106,F107,F108,F109,F110,F111,F112,F500,F501,F502,F503,F504,F505,F506,F507,F508,F509,F510,F511,F512,F1000,F1001,F1002,F1003,F1004,F1005,F1500,F1501,F1502,F1503,F1504,F2500,F2501,F2503,F2504,F4000,F4001,F4002,F4003,F4004,F4005,F4006,F4007,F4008,F4009,F4010,F4500,F4501,F4502,F4503,F4504,F4505,F4506,F4507,F4508,F4509,F4510,F5000,F5001,F5002,F5003,F5004,F5005

and

F1006,F1007,F1008,F5006,F5007,F5008

your code combines and sorts like this:

F100-F112, F500-F512, F1000-F1005, F1500-F1504, F2500, F2501, F2503, F2504, F4000-F4010, F4500-F4510, F5000-F5005, F1006-F1008, F5006-F5008,

It should look like this:

F100-F112, F500-F512, F1000-F1008, F1500-F1504, F2500, F2501, F2503, F2504, F4000-F4010, F4500-F4510, F5000-F5008

And if we look at the beginning of part number 7000280 with three original rows we see the beginning of these lines:

R140,R143,R144,R540,R543,R544,R1013,R1014...

and

R147,R547,R1501,R1504,R1506,R1508,R1515...

and

R1011

You return:

R140, R143, R144, R540, R543, R544, R1013-R1017, R1019-R1022, R1029, R3500, R3501...

but it should be:

R140, R143, R144, R147, R540, R543, R544, R547, r1011, R1013-R1017, R1019-R1022, R1029, R1501, R1504, R1506, R1508, R1515, ...R3500, R3501...

Part numbers with multiple rows should be combined/grouped/sorted across ALL reference designators associated with that part.

Does that help explain?

Let me know.

Tim

nutsch

My last update codes it properly, doesn't it?

Thomas

gibneyt

ASKER

Thomas,

I missed your reply, sorry. Yes, it sorts the data perfectly PERFECT. Thanks.

One request: Having the results sent to a different sheet is very handy for comparison. With headers if possible? can you assimilate that change please?

Thanks again.

Tim.

gibneyt

ASKER

BANG! Made to order Thomas! Thank you so much for your time. And a shout out to gowflow too.

Many thanks to your expertise.

Tim

nutsch

Hi Tim,

Here's the udpate. One thing on general EEtiquette: If your original question was answered, close the question and open another one for any additional requests. If your original question was not answered satisfactorily, then keep on asking in the same question.

In this case, your issues about the sorting and the two consecutive terms belonged in this question. The row consolidation and the different sheet should be in a different question.

Thomas

Option Explicit

Sub asdgag()
Dim shtTemp As Worksheet, shtOrg As Worksheet, shtFirst as worksheet
Dim lLastRow As Long, lRowLoop As Long, arrCode, lLoop As Long
Dim lLastRow2 As Long, lRowLoop2 As Long
Dim lLastRow3 As Long, lRowLoop3 As Long
Dim sFirstValue As String, lDestRow As Long, sLastValue As String
Dim sResults As String

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

set shtFirst= ActiveSheet
Set shtOrg = sheets.add

shtfirst.[a1].currentregion.copy shtorg.[a1]

consolidaterows

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set shtTemp = Sheets.Add

For lRowLoop = 1 To lLastRow
    If InStr(shtOrg.Cells(lRowLoop, 2), ",") > 0 Then
        shtTemp.Cells.ClearContents
        arrCode = Split(shtOrg.Cells(lRowLoop, 2), ",")
        
        For lLoop = LBound(arrCode) To UBound(arrCode)
            shtTemp.Cells(1 + lLoop, 1) = arrCode(lLoop)
        Next
        
        With shtTemp
        
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
            .Range("$A$1:$A$" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy .[b1]
            .Columns("B").Replace What:=RegExpFind(.[a1], "[A-Z]+", 1), Replacement:="", LookAt:=xlPart, _
                        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                        ReplaceFormat:=False
                        
            .Range("$A$1:$B$" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("B1"), Header:=xlNo
            .Columns("B").ClearContents
            lLastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
            lDestRow = 1
        
    
            For lRowLoop2 = 1 To lLastRow2
                
                If lRowLoop2 >= lLastRow2 Then GoTo lCloseLine:
                
                If RegExpFind(.Cells(lRowLoop2 + 1, 1), "[A-Z]+", 1) = RegExpFind(.Cells(lRowLoop2, 1), "[A-Z]+", 1) _
                    And CDbl(RegExpFind(.Cells(lRowLoop2 + 1, 1), "[0-9]+", 1)) = 1 + CDbl(RegExpFind(.Cells(lRowLoop2, 1), "[0-9]+", 1)) Then
                    If Len(sFirstValue) > 0 Then
                        sLastValue = .Cells(lRowLoop2 + 1, 1)
                    Else
                        If lRowLoop2 = lLastRow2 - 1 Then GoTo lCloseLine
                        If RegExpFind(.Cells(lRowLoop2 + 2, 1), "[A-Z]+", 1) = RegExpFind(.Cells(lRowLoop2, 1), "[A-Z]+", 1) _
                            And CDbl(RegExpFind(.Cells(lRowLoop2 + 2, 1), "[0-9]+", 1)) = 2 + CDbl(RegExpFind(.Cells(lRowLoop2, 1), "[0-9]+", 1)) Then
                                sFirstValue = .Cells(lRowLoop2, 1)
                                sLastValue = .Cells(lRowLoop2 + 1, 1)
                        Else
                            GoTo lCloseLine
                        End If
                    End If
                    GoTo lNextLine:
                
                End If
                
lCloseLine:
                If Len(sFirstValue) > 0 And Len(sLastValue) > 0 Then
                    .Cells(lDestRow, 2) = sFirstValue & "-" & sLastValue
                    sFirstValue = ""
                    sLastValue = ""
                Else
                    .Cells(lDestRow, 2) = .Cells(lRowLoop2, 1).Value
                End If
                
                lDestRow = lDestRow + 1

lNextLine:
            Next
        
            lLastRow3 = .Cells(Rows.Count, 2).End(xlUp).Row
            
            For lRowLoop3 = 1 To lLastRow3
                sResults = sResults & ", " & .Cells(lRowLoop3, 2)
            Next
            
            shtOrg.Cells(lRowLoop, 2) = Mid(sResults, 3)
            sResults = ""
        End With
        
        Set arrCode = Nothing
    End If
    
    
    
Next lRowLoop
     
shtTemp.Delete


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
    Optional MatchCase As Boolean = True, Optional ReturnType As Long = 0, _
    Optional MultiLine As Boolean = False)
    
    ' Function written by Patrick G. Matthews.  You may use and distribute this code freely,
    ' as long as you properly credit and attribute authorship and the URL of where you
    ' found the code
    
    ' This function relies on the VBScript version of Regular Expressions, and thus some of
    ' the functionality available in Perl and/or .Net may not be available.  The full extent
    ' of what functionality will be available on any given computer is based on which version
    ' of the VBScript runtime is installed on that computer
    
    ' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
    ' pattern (PatternStr).  Use Pos to indicate which match you want:
    ' Pos omitted               : function returns a zero-based array of all matches
    ' Pos = 1                   : the first match
    ' Pos = 2                   : the second match
    ' Pos = <positive integer>  : the Nth match
    ' Pos = 0                   : the last match
    ' Pos = -1                  : the last match
    ' Pos = -2                  : the 2nd to last match
    ' Pos = <negative integer>  : the Nth to last match
    ' If Pos is non-numeric, or if the absolute value of Pos is greater than the number of
    ' matches, the function returns an empty string.  If no match is found, the function returns
    ' an empty string.  (Earlier versions of this code used zero for the last match; this is
    ' retained for backward compatibility)
    
    ' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
    ' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).
    
    ' ReturnType indicates what information you want to return:
    ' ReturnType = 0            : the matched values
    ' ReturnType = 1            : the starting character positions for the matched values
    ' ReturnType = 2            : the lengths of the matched values
    
    ' If MultiLine = False, the ^ and $ match the beginning and end of input, respectively.  If
    ' MultiLine = True, then ^ and $ match the beginning and end of each line (as demarcated by
    ' new line characters) in the input string
    
    ' If you use this function in Excel, you can use range references for any of the arguments.
    ' If you use this in Excel and return the full array, make sure to set up the formula as an
    ' array formula.  If you need the array formula to go down a column, use TRANSPOSE()
    
    ' Note: RegExp counts the character positions for the Match.FirstIndex property as starting
    ' at zero.  Since VB6 and VBA has strings starting at position 1, I have added one to make
    ' the character positions conform to VBA/VB6 expectations
    
    ' Normally as an object variable I would set the RegX variable to Nothing; however, in cases
    ' where a large number of calls to this function are made, making RegX a static variable that
    ' preserves its state in between calls significantly improves performance
    
    Static RegX As Object
    Dim TheMatches As Object
    Dim Answer()
    Dim Counter As Long
    
    ' Evaluate Pos.  If it is there, it must be numeric and converted to Long
    
    If Not IsMissing(Pos) Then
        If Not IsNumeric(Pos) Then
            RegExpFind = ""
            Exit Function
        Else
            Pos = CLng(Pos)
        End If
    End If
    
    ' Evaluate ReturnType
    
    If ReturnType < 0 Or ReturnType > 2 Then
        RegExpFind = ""
        Exit Function
    End If
    
    ' Create instance of RegExp object if needed, and set properties
    
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Pattern = PatternStr
        .Global = True
        .IgnoreCase = Not MatchCase
        .MultiLine = MultiLine
    End With
        
    ' Test to see if there are any matches
    
    If RegX.Test(LookIn) Then
        
        ' Run RegExp to get the matches, which are returned as a zero-based collection
        
        Set TheMatches = RegX.Execute(LookIn)
        
        ' Test to see if Pos is negative, which indicates the user wants the Nth to last
        ' match.  If it is, then based on the number of matches convert Pos to a positive
        ' number, or zero for the last match
        
        If Not IsMissing(Pos) Then
            If Pos < 0 Then
                If Pos = -1 Then
                    Pos = 0
                Else
                    
                    ' If Abs(Pos) > number of matches, then the Nth to last match does not
                    ' exist.  Return a zero-length string
                    
                    If Abs(Pos) <= TheMatches.Count Then
                        Pos = TheMatches.Count + Pos + 1
                    Else
                        RegExpFind = ""
                        GoTo Cleanup
                    End If
                End If
            End If
        End If
        
        ' If Pos is missing, user wants array of all matches.  Build it and assign it as the
        ' function's return value
        
        If IsMissing(Pos) Then
            ReDim Answer(0 To TheMatches.Count - 1)
            For Counter = 0 To UBound(Answer)
                Select Case ReturnType
                    Case 0: Answer(Counter) = TheMatches(Counter)
                    Case 1: Answer(Counter) = TheMatches(Counter).FirstIndex + 1
                    Case 2: Answer(Counter) = TheMatches(Counter).Length
                End Select
            Next
            RegExpFind = Answer
        
        ' User wanted the Nth match (or last match, if Pos = 0).  Get the Nth value, if possible
        
        Else
            Select Case Pos
                Case 0                          ' Last match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(TheMatches.Count - 1)
                        Case 1: RegExpFind = TheMatches(TheMatches.Count - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(TheMatches.Count - 1).Length
                    End Select
                Case 1 To TheMatches.Count      ' Nth match
                    Select Case ReturnType
                        Case 0: RegExpFind = TheMatches(Pos - 1)
                        Case 1: RegExpFind = TheMatches(Pos - 1).FirstIndex + 1
                        Case 2: RegExpFind = TheMatches(Pos - 1).Length
                    End Select
                Case Else                       ' Invalid item number
                    RegExpFind = ""
            End Select
        End If
    
    ' If there are no matches, return empty string
    
    Else
        RegExpFind = ""
    End If
    
Cleanup:
    ' Release object variables
    
    Set TheMatches = Nothing
    
End Function
                                            
                                            
Private Sub ConsolidateRows()
'takes rows and consolidate one or many cells, based on one or many cells matching with above or below rows.

Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant

'**********PARAMETERS TO UPDATE****************
Const strMatch As String = "C"    'columns that need to match for consolidation, separated by commas
Const strConcat As String = "B"     'columns that need consolidating, separated by commas
Const strSep As String = ";"     'string that will separate the consolidated values
'*************END PARAMETERS*******************

Cells(1, 1).CurrentRegion.Sort Cells(1, 3), Header:=xlYes

colMatch = Split(strMatch, ",")
colConcat = Split(strConcat, ",")

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 2 Step -1 'loop from last Row to one
    
    For j = 0 To UBound(colMatch)
        If Cells(i, colMatch(j)) <> Cells(i - 1, colMatch(j)) Then GoTo nxti
    Next
    
    Cells(i - 1, "B") = Cells(i - 1, "B") & "," & Cells(i, "B")
    Cells(i - 1, "A") = Cells(i - 1, "A") + Cells(i, "A")
    
    
    Rows(i).Delete
    
nxti:
Next

End Sub

Open in new window

Jacques Geday

Well gibneyt
You hv a funny way of appreciating Expert's on the work they provide you. I don't know if it is your intention to close this question this way if it is by mistake then no problem if not, then tks for the nice appreciation.

gowflow

gibneyt

ASKER

Folks,

Thank you both so much for great, working code.

What is one to do? Thank their lucky stars? Bite their tongue? No!

gowflow,

Once the question is submitted and two or more EExperts start to tackle it, I am in the thankless position of deciding how to deliver the points. In this situation, the manner in which the code is created, as long as it provides the requested results, does not matter. If the question dealt with huge queries and many spreadsheets then the more robust/clean/refined code would be the choice, testing would be done and so on... In this instance I would not take the time. instead, with implicit trust and minimal non-rigorous review, I took the first across the finish line. Simply that. Like I said... BANG! And now I am shot! I am not sure why one of you would not demure to the other; first come? highest rank? You have to decide that. You both were reading the question and cannot be oblivious to the other. And my shout-out was "funny"! Chagrined!

Thomas,

The sorting and row consolidation were part and parcel of my intended request. I apologize for not vetting my data more carefully before posting the question The second sheet creation was not my doing but done de rigueur by gowflow, and perfectly logical! I requested you match what gowflow does in practice.

My only olive branch is this and it is bittersweet.

Moderators,

Please split the 500 points between gowflow and nutsch if possible. I'll use both sets of code on opposite days!

Regards,

Tim

gibneyt

ASKER

Thomas(nutsch),

I have come across an issue with the sorting in the VB script. Is this something we can work on again?

Tim