Solved

# Excel macro to group continuous alphanumeric terms in single cells

Posted on 2013-02-06
217 Views
Last Modified: 2013-06-18
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
0
Question by:gibneyt
[X]
###### Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points
• Learn & ask questions
• 9
• 5
• 5
19 Comments

LVL 29

Expert Comment

ID: 38860525
we are talking of Col B obviously right ?gowflow
0

Author Comment

ID: 38860609
gowflow,

Yes, that is correct.

Tim.
0

LVL 39

Expert Comment

ID: 38860662
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
``````
0

Author Comment

ID: 38861309
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
0

LVL 39

Expert Comment

ID: 38861393
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

``````
0

Author Comment

ID: 38861499
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
0

LVL 29

Expert Comment

ID: 38864059
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
0

Author Comment

ID: 38864681
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
0

LVL 39

Accepted Solution

nutsch earned 500 total points
ID: 38864769
Here is an update with row consolidation:

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

consolidaterows

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

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
``````
0

LVL 29

Expert Comment

ID: 38864820
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
0

LVL 29

Expert Comment

ID: 38864871
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
``````

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
0

Author Comment

ID: 38865706
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
0

LVL 39

Expert Comment

ID: 38865748
My last update codes it properly, doesn't it?

Thomas
0

Author Comment

ID: 38865838
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.
0

Author Closing Comment

ID: 38865866
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
0

LVL 39

Expert Comment

ID: 38865888
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
``````
0

LVL 29

Expert Comment

ID: 38865935
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
0

Author Comment

ID: 38868083
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
0

Author Comment

ID: 39245722
Thomas(nutsch),

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

Tim
0

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associateâ€¦
Excel can be a tricky bit of software to get your head around. Whilst youâ€™ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to dâ€¦
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns overâ€¦
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

#### 733 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.