VBA实现KMP和LCS算法

程序界面，包含了KMP算法和LCS算法。

从上图可以看出，LCS的解在某些情况下并非唯一的，下面的程序将用二种方法生成LCS串，可以得到上述2种不同的结果。

Private Sub CommandButton1_Click()  ''2021-1-24 KMP
  Dim S, T As String
  Dim i, j, n, m As Integer
  Dim Nexj() As Integer
   
''  S = InputBox("输入源字符串S:")
''  T = InputBox("请输入待查找的字符串T")
  
  S = Cells(3, "K")
  T = Cells(4, "K")
  
  If S = "" Or T = "" Then Exit Sub
  
  m = Len(S)
  n = Len(T)
  
  ReDim Nexj(1 To n)
   
 Call getNext(T, Nexj)
    
  i = 1: j = 1
 
  While i <= m - n + 1
    
      If Mid(S, i, 1) = Mid(T, j, 1) Then
         i = i + 1
         j = j + 1
      Else
        j = Nexj(j)
      End If
      
      If j = 0 Then
         j = 1
         i = i + 1
      End If
      
      If j > n Then    ''匹配成功
''         MsgBox "匹配成功的起始位置：" & Str(i - n), vbOKOnly, "匹配成功！"
         Cells(5, "K") = i - n
         Exit Sub
      End If
      
  Wend
   
   If i > m - n + 1 Then
''     MsgBox "没有找到！", vbOKOnly, "失败！"
     Cells(5, "K") = "没找到！"
   End If
  
End Sub

KMP主程序（按钮）

Private Sub CommandButton2_Click()   '' LCS
  Dim a, b As String
  Dim i, j, n, m As Integer
  Dim LenC() As Integer
  Dim ArrowC() As Integer  ''  \ 0 ,  | 1, <- 2  记录回溯的方向
  
''  a = InputBox("输入字符串a:", "A字符串")
''  b = InputBox("输入字符串b:", "B字符串")

  a = Cells(12, "F")
  b = Cells(13, "F")
  
  If a = "" Or b = "" Then Exit Sub
  
  m = Len(a)
  n = Len(b)
  
  ReDim LenC(0 To m, 0 To n)
  ReDim ArrowC(1 To m, 1 To n)
  
  Call Lcs_Len(a, b, LenC, ArrowC)      ''求数组
  
  Cells(14, "F") = BLCS(a, m, n, ArrowC)       ''输出，递归算法
  Cells(15, "F") = BuildLCS(a, LenC)         ''非递归
  
  MsgBox "Oooooooook！！！"
  
''  Debug.Print "*******************"
''  For i = 1 To m
''    For j = 1 To n
''      Debug.Print ArrowC(i, j);
''    Next j
''    Debug.Print
''  Next i
''  Debug.Print a, b
''  Debug.Print "LCS="; BLCS(a, m, n, ArrowC)
      
End Sub

LCS主程序（按钮）

Sub getNext(ByVal T As String, ByRef nextj() As Integer)
     Dim i, j As Integer
     
     i = 1
     nextj(1) = 0
     j = 0
     
     While i < Len(T)
     
        If j = 0 Then
             i = i + 1
             j = j + 1
             nextj(i) = j
        Else
             If Mid(T, i, 1) = Mid(T, j, 1) Then
                 i = i + 1
                 j = j + 1
                nextj(i) = j
             Else
                j = nextj(j)
             End If
        End If
         
     Wend
     
End Sub

Sub Lcs_Len(ByVal a As String, ByVal b As String, ByRef c() As Integer, ByRef arr() As Integer)
    Dim i, j As Integer
    Dim m, n As Integer
    
    m = Len(a)
    n = Len(b)
    
    For i = 0 To m
       c(i, 0) = 0
    Next i
    For i = 0 To n
       c(0, i) = 0
    Next i
    
    For i = 1 To m
       For j = 1 To n
            If Mid(a, i, 1) = Mid(b, j, 1) Then
               c(i, j) = c(i - 1, j - 1) + 1
               arr(i, j) = 0
            Else
               If c(i - 1, j) > c(i, j - 1) Then
                   c(i, j) = c(i - 1, j)
                   arr(i, j) = 1
               Else
                   c(i, j) = c(i, j - 1)
                   arr(i, j) = 2
               End If
            End If
       Next j
    Next i
    
End Sub

Public Function BuildLCS(ByVal a As String, ByRef LCS() As Integer) As String   ''构造LCS字符串 2022-1-25
   Dim m, n As Integer  '' a 串长 m，b串长 n , LCS()数组 m*n
   Dim i, j, k As Integer
   
   m = UBound(LCS, 1) ''1...m
   n = UBound(LCS, 2)
   k = LCS(m, n)           '' LCS=k
   
   i = m
   j = n
         
   BuildLCS = ""
   
   While k > 0   ''LCS字串只有k个字符
   
        If LCS(i, j) = LCS(i - 1, j) Then
                i = i - 1
        Else
                If LCS(i, j) = LCS(i, j - 1) Then
                     j = j - 1
                Else
                    BuildLCS = Mid(a, i, 1) & BuildLCS   ''上，左 都不相等时，必然是要找的字符
                     i = i - 1
                     j = j - 1
                    k = k - 1
                End If
        End If
                 
   Wend
     
End Function

Public Function BLCS(ByVal aaa As String, ByVal i As Integer, ByVal j As Integer, ByRef Ar() As Integer) As String    ''采用递归的方法构造LCS串
 
    If i = 0 Or j = 0 Then Exit Function
    If Ar(i, j) = 0 Then BLCS = BLCS(aaa, i - 1, j - 1, Ar) & Mid(aaa, i, 1)
    If Ar(i, j) = 1 Then BLCS = BLCS(aaa, i - 1, j, Ar)
    If Ar(i, j) = 2 Then BLCS = BLCS(aaa, i, j - 1, Ar)
 
End Function

模块1，其中包含了KMP算法里的核心：求next(j)的函数Sub getNext()，LCS里的计算LCS数组的过程Sub Lcs_Len()，以及回溯构造LCS字符串的递归与非递归的函数Public Function BLCS( )、Public Function BuildLCS( )。
值得一提的是，网上大多数教程都是以类C或java类语言写成的，如今以VBA（镶嵌在EXCEL里）写成，以图新鲜和供有需要的同学参考。
其次，在模块1中的Function BLCS()采用递归的方法生成LCS串，可以看出VBA是支持递归函数的以及它的实现过程。
最后一点：LCS的解并不是唯一的，从第一张截图可以看出。本程序采用2种方法构造LCS字串，所得结果都是正确的。