Sub Splits()
'Written: April 23, 2010
'Author: Leith Ross & Josh Russell
'from http://www.excelforum.com/excel-programming/726600-return-text-with-regex-find-function.html
'NOTE: requires a reference to the Microsoft VBScript Regular Expression type library
Dim SrcSht As Worksheet
Dim LastRow As Long
Dim SplitRng As Range
Dim SplitCol As Long
Dim SalesPeople As String, SplitRatio As String, MatchThis3 As String, MatchThis4 As String, MatchThis5 As String
Dim UnitName As String, UnitNum As String
Dim S1 As String, S2 As String, S3 As String, S4 As String, S5 As String
Dim T1 As Boolean, T2 As Boolean, T3 As Boolean, T4 As Boolean, T5 As Boolean
Dim i As Long
Dim re As New RegExp 'was Object
Dim ma As Match
Dim maCol As MatchCollection
Dim MatchArrayName() As Variant
Dim MatchArrayNum() As Variant
Dim S2Array() As Variant
Dim ma2 As Match
Dim ma2Col As MatchCollection
Dim j As Long
Dim k As Integer
Dim TempText As String
Dim val1 As Long, val2 As Long, val3 As Long
Dim ResultRow As Long
Set SrcSht = ActiveSheet
LastRow = SrcSht.UsedRange.Rows.Count
'find "Split Info" column
Set SplitRng = Rows("1:1").Find(What:="Split Info", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
SplitCol = SplitRng.Column
ResultRow = LastRow + 3
Set re = CreateObject("VBScript.RegExp")
re.Global = False
re.IgnoreCase = True
'as Leith Ross wrote
'SalesPeople = "^[a-zA-Z'\/\s]+\s|\s[a-zA-Z'\/\s]+\s|\s[a-zA-Z'\/\s]+$"
'SplitRatio = "^[\/\d]+\s|\s[\/\d]+\s|\s[\/\d]+$"
'(word-slash[mandatory])-word-slash 1 or more times, matching only 2 char words or longer
SalesPeople = "\s?[a-zA-Z' ]{2,}\s?\/(\/?\s?[a-zA-Z' ]{2,}\s?)+"
'slash-number-slash 2 or more times
SplitRatio = "(\/?\s?\d+\s?){2,}"
'name-number-slash format, 3 or 2 times
MatchThis3 = "(\/?[a-zA-Z' ]{2,}\s?,?\s?\d+\s?,?\s?){2,3}"
'name-dash-number-colon format, 3 or 2 times
MatchThis4 = "([a-zA-Z' ]{2,}\s?,?\s?-\s?,?\s?\d+\s?,?\s?:?){2,3}"
'number-dash-name format, 3 or 2 times
MatchThis5 = "(\d+\s?\-\s?[a-zA-Z']{2,},?\s?){2,3}"
'break it down into units, need regex patterns for each name and number
UnitName = "[a-zA-Z' ]{2,}"
UnitNum = "\d+"
j = -1
'for each row where "Split Info" column is not empty
For i = 2 To LastRow
If IsEmpty(Cells(i, SplitCol)) Then GoTo ResetLine
re.Global = False
re.Pattern = SalesPeople
T1 = re.Test(Cells(i, SplitCol))
If T1 Then
S1 = re.Execute(Cells(i, SplitCol))(0) 'S1 = names div by slashes
re.Global = True
j = -1
re.Pattern = UnitName
Set maCol = re.Execute(S1)
ReDim MatchArrayName(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayName(0, j) = ma.Value
MatchArrayName(1, j) = ma.FirstIndex
Next
End If
TempText = Cells(i, SplitCol).text
TryAgainWithoutDate:
re.Global = False
re.Pattern = SplitRatio
T2 = re.Test(TempText)
If T2 Then
Set ma2Col = re.Execute(TempText) 'S2 = numbers div by slashes 'removing(0) fixed type mismatch
ReDim S2Array(1, 0) As Variant
For Each ma2 In ma2Col
S2Array(0, 0) = ma2.Value
S2Array(1, 0) = ma2.FirstIndex
Next
re.Global = True
j = -1
re.Pattern = UnitNum
Set maCol = re.Execute(S2Array(0, 0)) 'original
ReDim MatchArrayNum(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayNum(0, j) = ma.Value
MatchArrayNum(1, j) = ma.FirstIndex
Next
If j = 2 Then
val1 = Val(MatchArrayNum(0, 0))
val2 = Val(MatchArrayNum(0, 1))
val3 = Val(MatchArrayNum(0, 2))
If val1 + val2 + val3 <> 100 Then
k = S2Array(1, 0) + 1
TempText = WorksheetFunction.Replace(TempText, k, 8, "________") 'figure out where S2 is in larger thing, get new S2
GoTo TryAgainWithoutDate
End If
End If
End If
re.Global = False
re.Pattern = MatchThis3
T3 = re.Test(Cells(i, SplitCol))
If T3 Then
S3 = re.Execute(Cells(i, SplitCol))(0) 'S3 = name-number-slash format, 3 or 2 times
re.Global = True
j = -1
re.Pattern = UnitName
Set maCol = re.Execute(S3)
ReDim MatchArrayName(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayName(0, j) = ma.Value
MatchArrayName(1, j) = ma.FirstIndex
Next
j = -1
re.Pattern = UnitNum
Set maCol = re.Execute(S3)
ReDim MatchArrayNum(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayNum(0, j) = ma.Value
MatchArrayNum(1, j) = ma.FirstIndex
Next
GoTo FoundResults
End If
re.Global = False
re.Pattern = MatchThis4
T4 = re.Test(Cells(i, SplitCol))
If T4 Then
S4 = re.Execute(Cells(i, SplitCol))(0) 'S4 = name-dash-number-colon format, 3 or 2 times
re.Global = True
j = -1
re.Pattern = UnitName
Set maCol = re.Execute(S4)
ReDim MatchArrayName(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayName(0, j) = ma.Value
MatchArrayName(1, j) = ma.FirstIndex
Next
j = -1
re.Pattern = UnitNum
Set maCol = re.Execute(S4)
ReDim MatchArrayNum(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayNum(0, j) = ma.Value
MatchArrayNum(1, j) = ma.FirstIndex
Next
GoTo FoundResults
End If
re.Global = False
re.Pattern = MatchThis5
T5 = re.Test(Cells(i, SplitCol))
If T5 Then
S5 = re.Execute(Cells(i, SplitCol))(0) 'S5 = number-dash-name format, 3 or 2 times
re.Global = True
j = -1
re.Pattern = UnitName
Set maCol = re.Execute(S5)
ReDim MatchArrayName(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayName(0, j) = ma.Value
MatchArrayName(1, j) = ma.FirstIndex
Next
j = -1
re.Pattern = UnitNum
Set maCol = re.Execute(S5)
ReDim MatchArrayNum(1, maCol.Count - 1) As Variant
For Each ma In maCol
j = j + 1
MatchArrayNum(0, j) = ma.Value
MatchArrayNum(1, j) = ma.FirstIndex
Next
GoTo FoundResults
End If
Text too long... continued in next post.
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks