Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=160990&TITLE_SEO=160990-naibolee-dlinnaya-podstroka
'==================================================================================================
Private Function pv_Longest_common_substring(string1 As String, string2 As String) As String
    Dim i As Integer, j As Integer, temp As String, result As String
    For i = 1 To Len(string1)
        For j = 1 To Len(string1)
            temp = Mid(string1, i, j)
            If InStr(string2, temp) Then
                If Len(temp) > Len(result) Then result = temp
            End If
        Next
    Next
    pv_Longest_common_substring = result
End Function
'==================================================================================================
Function Longest(r As Range) As String
Dim dx, s() As String, s1$, s2$, n&, i&

    dx = r.Value
    For n = 1 To UBound(dx)
        ReDim Preserve s(0 To n - 1)
        s(n - 1) = dx(n, 1)

    Next
    s1$ = s(0)

    For i = 1 To UBound(s)
        s2$ = s(i)
        s1 = pv_Longest_common_substring(s1, s2)
    Next
    Longest = s1
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Function pv_Rng_GetUniqStrings(rngIn As Range, lMin_Out&, sMin_Out$, aStrOth_Out() As String) As Boolean
Dim x, arr, a&, l&, n&, nMin&
Static dic As New Dictionary

ReDim aStrOth_Out(rngIn.Cells.CountLarge)
lMin_Out = 40000

For a = 1 To rngIn.Areas.Count
    arr = rngIn.Areas(a).Value2
    If Not IsArray(arr) Then arr = Array(arr)

    For Each x In arr
        If (VarType(x) <> vbString) Then GoTo nx
        If (x = "") Then GoTo nx
        If dic.Exists(x) Then GoTo nx
        
        n = n + 1: aStrOth_Out(n) = x
        dic.Add aStrOth_Out(n), 0
        l = Len(aStrOth_Out(n)): If (lMin_Out > l) Then lMin_Out = l: nMin = n
    Next x
nx:
Next a

dic.RemoveAll: If (nMin = 0) Then Exit Function
sMin_Out = aStrOth_Out(nMin)

For a = nMin + 1 To n
    aStrOth_Out(a - 1) = aStrOth_Out(a)
Next a

ReDim Preserve aStrOth_Out(n - 1)
pv_Rng_GetUniqStrings = True
End Function
'--------------------------------------------------------------------------------------------------
Private Function pv_MainSubString(lMin_In&, sMin_In$, aStrOth_In() As String, lMax_Out&, sSubStr_Out$) As Boolean
Dim sSrch$, n&, i&, lSrch&

lMax_Out = 0: i = 1: lSrch = 1

Do
rp: sSrch = Mid$(sMin_In, i, lSrch)

    For n = 1 To UBound(aStrOth_In)
        If (InStr(aStrOth_In(n), sSrch) = 0) Then
            If (lMax_Out >= lMin_In - i) Then GoTo ex
            i = i + 1: lSrch = 1: GoTo rp
        End If
    Next n

    If (lMax_Out < lSrch) Then lMax_Out = lSrch: sSubStr_Out = sSrch
    If (lMin_In = i + lSrch - 1) Then GoTo ex Else lSrch = lSrch + 1
Loop

ex: If (lMax_Out <> 0) Then pv_MainSubString = True
End Function
'--------------------------------------------------------------------------------------------------
Function MainSubString(rng As Range) As String
Dim aStr$(), sMin$, lMin&, lMax&
    If Not pv_Rng_GetUniqStrings(rng, lMin, sMin, aStr) Then Exit Function
    pv_MainSubString lMin, sMin, aStr, lMax, MainSubString
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim rng As Range
Dim s$, t!, n&

Set rng = [a2:a5]   ' v1(4  Cells)

t = Timer
    For n = 1 To 10000
'        s = MainSubString(rng) ' 0.4
'        s = Longest(rng)       ' 3.0
    Next n
Debug.Print Format$(Timer - t, "0.0"), s
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================