Posts by jindon

Function GetSimilar(rng As Range, Exc As Range, ref As Long) As String
    Dim r As Range, m As Object, e, myPtn As String
    Dim RegX As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each r In Exc
        If r.Value <> "" Then dic(r.Value) = Empty
    Next
    For Each r In rng
        If r.Value <> "" Then
            If RegX Is Nothing Then
                Set RegX = CreateObject("VBScript.RegExp")
                RegX.Global = True: RegX.IgnoreCase = True
                RegX.Pattern = "[,\.:;\?!&\(\)\-\|\\\[\]\+\*\{\}]"
                myPtn = Application.Trim(RegX.Replace(r.Value, " "))
                RegX.Pattern = "\b(" & Replace(myPtn, " ", "|") & ")\b"
            Else
                For Each m In RegX.Execute(r.Value)
                    If Not dic.exists(m.submatches(0)) Then
                        myPtn = myPtn & "|" & m.submatches(0)
                    End If
                Next
                If Len(myPtn) Then
                    GetSimilar = Trim$(Replace(myPtn, "|", " "))
                    RegX.Pattern = "\b(" & Mid$(myPtn, 2) & ")\b"
                Else
                    GetSimilar = "No word": Exit For
                End If
                myPtn = ""
            End If
        End If
    Next
    If Len(GetSimilar) Then GetSimilar = Split(GetSimilar)(ref - 1)
    Set RegX = Nothing
    Set dic = Nothing
End Function

Function GetSimilar(rng As Range, Exc As Range) As String
    Dim r As Range, m As Object, e, myPtn As String
    Dim RegX As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For Each r In Exc
        If r.Value <> "" Then dic(r.Value) = Empty
    Next
    For Each r In rng
        If r.Value <> "" Then
            If RegX Is Nothing Then
                Set RegX = CreateObject("VBScript.RegExp")
                RegX.Global = True
                RegX.Pattern = "\b(" & Replace(r.Value, " ", "|") & ")\b"
            Else
                For Each m In RegX.Execute(r.Value)
                    If Not dic.exists(m.Value) Then
                        myPtn = myPtn & "|" & m.Value
                    End If
                Next
                If Len(myPtn) Then
                    GetSimilar = Trim$(Replace(myPtn, "|", " "))
                    RegX.Pattern = "\b(" & Mid$(myPtn, 2) & ")\b"
                Else
                    GetSimilar = "No word": Exit For
                End If
                myPtn = ""
            End If
        End If
    Next
    Set RegX = Nothing
    Set dic = Nothing
End Function

Sub test()
    Dim a, b, i As Long, ii As Long, x, e, n As Long
    a = Sheets("suivi").Cells(1).CurrentRegion.Value
    ReDim b(1 To 10000, 1 To 11)
    For i = 1 To UBound(a, 1)
        x = SplitRef(a(i, 3))
        For Each e In x
            n = n + 1
            b(n, 1) = a(i, 1): b(n, 2) = e
            For ii = 5 To 13
                b(n, ii - 2) = a(i, ii)
            Next
        Next
    Next
    With Sheets("result").Cells(1).Resize(n, 11)
        With .CurrentRegion
            .Borders.LineStyle = xlNone
            .ClearContents
        End With
        .Value = b
        .Cells(1, 2).Value = "PN " & .Parent.Name
        With .Cells(1, 4).Resize(, 7)
            .Value = .Parent.Evaluate("""" & .Parent.Name & """&char(10)&" & .Address)
        End With
        .Borders.Weight = 2
    End With
End Sub




Function SplitRef(ByVal txt As String)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "/-+[A-Z]*; *"
        If .test(txt) Then
            SplitRef = Split(Trim$(.Replace(txt, " ")))
        Else
            SplitRef = Array(txt)
        End If
    End With
End Function

Sub test()
    Dim r As Range, myBase As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "=(([A-Z]+\d+)[\-\+\*/]([A-z]+\d+))"
        For Each r In Columns("d:e").SpecialCells(-4123, 1)
            If .test(r.Formula) Then
                myBase = IIf(r.Column = 4, "$3", "$2")
                r.Formula = .Replace(r.Formula, "=if(" & myBase & "="""","""",$1)")
            End If
        Next
    End With
End Sub

Sub test()
    Dim r As Range, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each r In Selection
        If r.Value <> "" Then
            For Each e In Split(r.Value)
                If Not dic.exists(e) Then
                    dic(e) = True
                Else
                    dic(e) = False
                End If
            Next
        End If
    Next
    For Each e In dic
        If Not dic(e) Then dic.Remove e
    Next
    If dic.Count Then
        MsgBox Join(dic.keys, vbLf)
    Else
        MsgBox "No word"
    End If
End Sub

Option Explicit
Private dic As Object


Private Sub UserForm_Initialize()
    Dim a, i As Long, ii As Long, w
    a = Sheets("ark1").[c1].CurrentRegion.Value
    ReDim w(1 To 5)
    Set dic = CreateObject("Scripting.Dictionary")
    ComboBox1.RowSource = ""
    For i = 2 To UBound(a, 1)
        For ii = 1 To 5
            w(ii) = a(i, ii + 1)
        Next
        dic(a(i, 1)) = w
    Next
    Me.ComboBox1.List = dic.keys
End Sub


Private Sub ComboBox1_Change()
    Dim e, AL As Object, i As Long
    Set AL = CreateObject("System.Collections.ArrayList")
    ClearTB 1, 5
    With Me.ComboBox1
        If .Value <> "" Then
            If dic.exists(.Value) Then
                .List = Array(.Value)
            Else
                For Each e In dic
                    If UCase$(e) Like UCase$(.Value) & "*" Then AL.Add e
                Next
                If AL.Count Then
                    .List = AL.ToArray
                    .DropDown
                Else
                    .List = dic.keys
                End If
            End If
            If .ListIndex > -1 Then
                For i = 1 To 5
                    Me("textbox" & i).Value = dic(.Value)(i)
                Next
            End If
        Else
            .List = dic.keys
        End If
    End With
End Sub


Private Sub CommandButton1_Click()
    Unload Me
End Sub


Private Sub ClearTB(s, e)
    Dim i As Long
    For i = s To e
        Me("textbox" & i).Value = ""
    Next
End Sub