Function SaiRangChiu(s As String) As String
' get rid of repeating and redundant subject names
' That is: TinA1. TinA2. TinA3. LyA1. LyA2. LyA3. HoaA1. HoaA2. -> TinA1.A2.A3. LyA1.A2.A3. HoaA1.A2
' within the following code: Toan, Tin,... are called subject categories, and A1, A2 are subject subdivisions
Dim aSubjectCats ' serves as an array of subject categories
Dim aSubjects() As String ' this array is for packing subjects into their respective cats
Dim sPart ' represents each subject element within input string
Dim aLo As Integer, aHi As Integer, cat As Integer ' counters
aSubjectCats = Array("Toan", "Tin", "Ly", "Hoa", "Van") ' define subject categories
aLo = LBound(aSubjectCats)
aHi = UBound(aSubjectCats)
ReDim aSubjects(aLo To aHi)
For Each sPart In Split(Replace(s, " ", ""), ".") ' traverse input string in parts
For cat = aLo To aHi
If sPart Like aSubjectCats(cat) & "*" Then Exit For ' search subject's category
Next cat
If cat <= aHi Then ' category found
If aSubjects(cat) <> "" Then ' category already registered
aSubjects(cat) = aSubjects(cat) & "." & Replace(sPart, aSubjectCats(cat), "")
Else
aSubjects(cat) = sPart ' place subject in, and at the same time, register cat
End If
End If
Next sPart
SaiRangChiu = Replace(Application.Trim(Join(aSubjects, " ")), " ", ". ")
End Function
Function UniqueSubject(ByVal Text$)
With VBA.CreateObject("VBScript.RegExp")
.Global = True: .ignorecase = False
.Pattern = "([a-z]+[A-Z] *)(?=.*\1)"
Text = StrReverse(Text) & " "
If .test(Text) Then UniqueSubject = StrReverse(.Replace(Text & " ", ""))
End With
End Function
Test thấy đúng mà vẫn không hiểu cái này là cái gì
Phân tích ([a-z]+[A-Z] *)(?=.*\1) ra là thầy hiểu:
RegEx này khó quá bác ạ!
Cám ơn bạn đã phân tích ..... làm mình thêm tí xíu về việc hiểu về cái này!
Sub CheckOrderUP_test()
Debug.Print CheckOrderUP("AnhB1.B2.EmC1.C2", "AnhB1.B2.B3.Em.C1.C2.C3")
Debug.Print CheckOrderUP("AnhB1.B2.B3.EmC1.C2.C3", "AnhB1.B2.EmC1.C2")
End Sub
Function CheckOrderUP(ByVal Text1$, ByVal Text2$)
Dim M1, M2, M3, N1, N2, S, P$
With VBA.CreateObject("VBScript.RegExp")
.Global = True: .IgnoreCase = False
P = "(?:[A-Z]+\d+(?:\.|$))"
.Pattern = "([A-Z][a-z]+)\.?(" & P & "+)"
If Not .Test(Text1) Or Not .Test(Text2) Then Exit Function
Set M1 = .Execute(Text1): Set M2 = .Execute(Text2)
For Each N1 In M1
For Each N2 In M2
.Pattern = N2.SubMatches(0) & "\.*" & N2.SubMatches(1) & "\.*(" & P & "+)"
If .Test(N1) Then
S = S & IIf(S = "", "KQ Gi" & ChrW(7843) & "m ", ",") & N1.SubMatches(0) & .Execute(N1)(0).SubMatches(0)
Else
.Pattern = N1.SubMatches(0) & "\.*" & N1.SubMatches(1) & "\.*(" & P & "+)"
If .Test(N2) Then
S = S & IIf(S = "", "KQ t" & ChrW(259) & "ng ", ",") & N2.SubMatches(0) & .Execute(N2)(0).SubMatches(0)
End If
End If
Next
Next
End With
CheckOrderUP = Replace(S, ".,", ",")
End Function
Function Gop(ByVal sStr As String) As String
Dim aTmp As Variant, i As Long, sPattern As String
sStr = Tach(sStr)
aTmp = Split(sStr, ".")
RemoveSpace aTmp
For i = LBound(aTmp, 1) To UBound(aTmp, 1)
If aTmp(i) <> "" Then
sPattern = Left(aTmp(i), Len(aTmp(i)) - 2) & "?#"
aTmp(i) = " " & aTmp(i) & "."
For j = i + 1 To UBound(aTmp, 1)
If aTmp(j) Like sPattern Then
aTmp(i) = aTmp(i) & Right(aTmp(j), 2) & "."
aTmp(j) = ""
End If
Next
End If
Next
Gop = Mid(Join(aTmp, ""), 2)
End FunctionFunction Tach(ByVal sStr As String) As String
Dim aTmp As Variant, i As Long, sPattern As String
aTmp = Split(sStr, ".")
RemoveSpace aTmp
For i = LBound(aTmp, 1) To UBound(aTmp, 1)
If aTmp(i) <> "" And Not aTmp(i) Like "?#" Then
sPattern = Left(aTmp(i), Len(aTmp(i)) - 2)
aTmp(i) = " " & aTmp(i) & "."
For j = i + 1 To UBound(aTmp, 1)
If aTmp(j) Like "?#" Then
aTmp(i) = aTmp(i) & " " & sPattern & aTmp(j) & "."
aTmp(j) = ""
Else
Exit For
End If
Next
End If
Next
Tach = Mid(Join(aTmp, ""), 2)
End FunctionFunction Tru(ByVal sStr1 As String, ByVal sStr2 As String) As String
Dim aTmp As Variant, i As Long
sStr1 = ". " & Replace(Tach(sStr1), ".", "..")
sStr2 = Tach(sStr2)
aTmp = Split(sStr2, ".")
RemoveSpace aTmp
For i = LBound(aTmp, 1) To UBound(aTmp, 1)
sStr1 = Replace(sStr1, ". " & aTmp(i) & ".", "")
Next
Tru = Gop(Replace(sStr1, "..", "."))
End FunctionPrivate Sub RemoveSpace(ByRef Arr As Variant)
Dim i As Long
For i = LBound(Arr, 1) To UBound(Arr, 1)
Arr(i) = Trim(Arr(i))
Next
End SubNhìn cái yêu cầu đầu ra muốn bắt bịnh rồi. Loại yêu cầu này đến đâu chữa đến đó chứ hơi đâu mà tổng quát.
Tổng quát ở mức độ nào đó thôi. Ví dụ, ban đầu có TinA1. TinA2. TinA3. LyA1. LyA2. LyA3. HoaA1. HoaA2., bây giờ muốn thêm TinA4 thì thêm vào cuối vẫn được, không lẽ bắt buộc phải thêm đúng chỗ.
