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
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
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
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.
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
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
Title | # Comments | Views | Activity |
---|---|---|---|
Excel VBA - Gather data into a single summary sheet from multiple worksheets | 7 | 25 | |
Splitting out Data | 14 | 28 | |
Excel Autofill Dropdown List with Combobox : How to make use of Tab and Enter key to input a value. | 5 | 23 | |
TT Status Chang | 3 | 32 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!