程序设计：利用Excel的“条件格式”（填充），美化和保存“比对结果”（*.xlsx） - VB6论坛

得分:0

图片附件: 游客没有浏览图片的权限，请登录或注册

“多行形式”的文本比对与“文章形式”的文本比对虽然在算法上基本相同，但是“多行形式”的比对结果的表示却有特别的要求：1 两边的“对应相同行”要全部“左右对齐”（这需要插入斜纹行来调节）；2 两边的“特殊行”要有醒目的底纹（颜色填充）；3 左右两部分要“同步滚动”。
我的解决方法是：1 利用“比对过程中获得的2个二维数组 QS()、CD()”插入斜纹行来调节。2 和 3 需要先利用QS()、CD()，在两边的“特殊行”的行首标上“!”，然后把比对结果送到 Excel ，用“条件格式”加上醒目的底纹（颜色填充）来完成。这样的文件，脱离比对程序也可以打开浏览。

什么是“特殊行”?我在下文中会有说明。
    我们可以从如下的视角来理解要比对的“文本A”与“文本B”之间的关系：
    先把“文本A”复制一份，名为“A副本”，然后把“A副本”进行编辑,最后把编辑完的“A副本”改名为“文本B”。
    当比对程序在比对过程中发现对“A副本”做过“删除行”和“修改行”的操作时，比对程序会在“文本A”的对应行的行首标注记号“! ”（似乎是为了“有案可查”）;当比对程序发现对“A副本”做过“插入行”的操作时，比对程序会在那些插入的行和修改后的行的行首也标注记号“! ”。
这样一来，Excel 的“条件格式”功能就能通过“填充颜色”来醒目地显示两个文本中的“特殊的行”了。“文本A”中那些为了“备案‘被删除、被修改’而打上记号的行”和“文本B”中“外来的行”就是“特殊行”。
    我的“文本比对程序”的设计思路是：对“文本B”中的每一行，从上到下进行鉴别：这一行【是不是“A副本”中原本已有的行（不该加标记的行）】。鉴别的依据是：是否符合（两边的对应行）是不是“一一对应”、上下顺序一致（这2点容易做到）、“A副本”中保留最多的不动的行。（3个原则）
    鉴别过程中，必须注意要收集“副产品”。什么副产品呢？就是：每一次编辑（删除行、插入行、修改行）的“起始行号”QS()和编辑的“行数”CD()。【其实是重要的、关键的数据】。观察看图“Book1”的前 15、16行：
正是由 QS()和CD() 记录了两个文本中的“特殊的行”。我们才得以在两个文本中插入“斜纹行”和标注记号“!”

2点说明：
1.注意“最长公共子序列”的算法规则：
“文本A”中“没有标注记号的行”与“文本B”中“没有标注记号的行”形成“一一对应、顺序一致”的关系。也就是说，那些行组成了“文本A”与“文本B”的“公共子序列”。
我们知道，“文本比对算法”有一个“潜——默认的规则”：让“A副本”保留最多的、不编辑（不改动）的行。这似乎有点不好理解。我举个例子：
例：“文本A”有5行，每行2个字，按由上到下分别是“男1、男2、男3、男4、女1”。
    “文本B”也有5行，每行2个字，按由上到下分别是“女1、男1、男2、男3、男4”。
对于文本由A到B的变化，我们一般会说：“后来，女1排到4位男士的前面去了”（保留最多不动的行），而不说“后来，4位男士排到女1的后面去了”。
所以程序是在两边“女1”的那一行的行首加上“！”符号。（只有1行、而不是4行加符号）。虽然实际情况是一样的，但是，如果不约定好统一的表达方式，那么比对结果的表示就会让人看不懂。
2.【利用QS()和CD()】加 “!”标记、加“斜纹行”。给每一行加行号。
当两边的CD()值不相等时，（为了对齐）就要在“少”的那一边插入若干“斜纹行”。
当CD()值大于零时，就要在行首加上“！”，以让 Excel 的“条件格式”识别、填充颜色。
rar压缩文件中有全部的VB代码（.txt）。
这是自编的程序，如果读者发现有错误和不妥，请给我指出。如有疑问，也请提出，我会尽力解答。谢谢!

Option Explicit '这是全部代码
Dim n1   As Integer, n2 As Integer
Dim L1   As Integer, L2 As Integer
Dim QS() As Integer, CD() As Integer, table%(), mnMAX%, mn%
Dim tx1$, tx2$, ZT$
Dim fnL$, fnR$
Dim LS$(), RS$()

Private Sub Form_Load()
    Form1.Show
    Label12.Caption = "编辑前"
    Label13.Caption = "编辑后"
    Label7.Caption = "请打开 Excel ，单击 A1 单元格，按 Ctrl-v 粘贴，" & vbCrLf & "然后用【条件格式】设置“行首为‘！’符号”的单元格的“填充格式”。"
End Sub

Private Sub CmdOpL_Click() '打开左边文件到 LS()
    Dim xx$, n%, txt$, i%
    Dim fn$
    CommonDialog1.DialogTitle = "打开左边文件"
    CommonDialog1.FileName = ""
    CommonDialog1.Filter = "打开左边文件|*.*"
    CommonDialog1.Action = 1
    CommonDialog1.FilterIndex = 1
    fn = CommonDialog1.FileName
    CommonDialog1.InitDir = CurDir
    fnL = CommonDialog1.FileTitle
    CmdOpL.Enabled = False
    If fn = "" Then Exit Sub
    n = 0
    Open fn For Input As #1
    Do While Not EOF(1)
        Line Input #1, xx
        If xx <> "" Then
            n = n + 1
            ReDim Preserve LS(n)
            LS(n) = xx
            txt = txt & xx & vbCrLf
        End If
    Loop
    Close #1
    L1 = n
    Label12.Caption = fnL
    Text1.Text = txt
    tx1 = txt
End Sub

Private Sub CmdOpR_Click() '打开右边文件到 RS()
    Dim fn$, xx$, n%, txt$, i%
    CommonDialog1.DialogTitle = "打开右边文件"
    CommonDialog1.FileName = ""
    CommonDialog1.Filter = "打开右边文件|*.*"
    CommonDialog1.Action = 1
    CommonDialog1.FilterIndex = 1
    fn = CommonDialog1.FileName
    CommonDialog1.InitDir = CurDir
    fnR = CommonDialog1.FileTitle
    CmdOpR.Enabled = False
    If fn = "" Then Exit Sub
    n = 0
    Open fn For Input As #1
    Do While Not EOF(1)
        Line Input #1, xx
        If xx <> "" Then
            n = n + 1
            ReDim Preserve RS(n)
            RS(n) = xx
            txt = txt & xx & vbCrLf
        End If
    Loop
    Close #1
    L2 = n
    Label13.Caption = fnR
    Text2.Text = txt
    tx2 = txt
End Sub

Private Function LCS(ByVal b As Integer, ByVal a As Integer) As Integer '递归函数
    Dim i%, j1%, k2%, m%
    Dim zn1$, zn2$, b1%, a2%
    Dim z1$
    b1 = b
    a2 = a
    Do
        zn1 = LS(b1)
        zn2 = RS(a2)
        If zn1 = zn2 Then '①
            m = m + 1
            b1 = b1 + 1
            a2 = a2 + 1 '''''
        Else '②或③1或③2
            i = 1
            Do
                If b1 = L1 Then
                    Exit Do
                End If
                z1 = LS(b1 + i)
                If z1 = zn2 Then
                    For j1 = b1 To b1 + i - 1
                        For k2 = a2 + 1 To L2
                            If RS(k2) = LS(j1) Then
                                If table(j1, k2) = 0 Then table(j1, k2) = LCS(j1, k2)
                                If table(b1 + i, a2) = 0 Then table(b1 + i, a2) = LCS(b1 + i, a2)
                                If table(j1, k2) > table(b1 + i, a2) Then '
                                    Exit Do ' ③2
                                End If
                                Exit For
                            End If
                        Next
                    Next
                    '③1
                        m = m + 1
                        b1 = b1 + i + 1
                        i = 0
                        Exit Do '③1
                End If
                i = i + 1
            Loop Until b1 + i > L1 '②或③2
            '②或③1或③2---除了①
            a2 = a2 + 1
        End If
        DoEvents
    Loop Until ((b1 > L1) Or (a2 > L2))
    LCS = m
End Function

Private Sub CmdMain_Click() '【计算】（命令按钮）
    '搜索和储存“编辑位置QS”和“编辑长度CD”
    Dim zn1$, zn2 As String, m%, n%, i%
    Dim j1 As Integer, k2 As Integer, r As Integer, Tmp%
    Dim z1$
    Form1.MousePointer = 11
    ReDim Preserve table(L1, L2), QS(1, 0), CD(1, 0)
    n = LCS(1, 1)
    Form1.MousePointer = 0
    mn = 0
    n1 = 1
    n2 = 1
    ZT = ""
    Do
        zn1 = LS(n1)
        zn2 = RS(n2)
        If zn1 = zn2 Then '①
            m = m + 1
            n1 = n1 + 1
            If Tmp > 0 Then
                CD(0, mn) = 0
                CD(1, mn) = Tmp
            End If
            Tmp = 0
        Else
            If Tmp = 0 Then
                mn = mn + 1
                ReDim Preserve QS(1, mn)
                ReDim Preserve CD(1, mn)
                QS(0, mn) = n1
                QS(1, mn) = n2
            End If
            r = 1
            Do
                If n1 = L1 Then
                    Exit Do
                End If
                z1 = LS(n1 + r)
                If z1 = zn2 Then '③
                    For j1 = n1 To n1 + r - 1
                        For k2 = n2 + 1 To L2
                            If LS(j1) = RS(k2) Then
                                If table(j1, k2) > table(n1 + r, n2) Then
                                    Exit Do ' ③2
                                End If
                                Exit For
                            End If
                        Next  '
                    Next
                    ' ③1
                    m = m + 1
                    CD(0, mn) = r
                    CD(1, mn) = Tmp
                    n1 = n1 + r + 1
                    r = 0
                    Tmp = -1
                    Exit Do
                End If
                r = r + 1
            Loop Until n1 + r > L1
            Tmp = Tmp + 1 '②或③1或③2
        End If
        n2 = n2 + 1 '①②或③1或③2
    Loop Until ((n1 > L1) Or (n2 > L2))
    If n1 <= L1 Then
        If Tmp = 0 Then
            mn = mn + 1
            ReDim Preserve QS(1, mn)
            ReDim Preserve CD(1, mn)
            QS(0, mn) = n1
            QS(1, mn) = n2
        End If
        CD(0, mn) = L1 - n1 + 1
        CD(1, mn) = Tmp
        Tmp = 0
    End If
    If n2 <= L2 Then
        mn = mn + 1
        ReDim Preserve QS(1, mn)
        ReDim Preserve CD(1, mn)
        QS(0, mn) = n1
        QS(1, mn) = n2
        CD(0, mn) = 0
        CD(1, mn) = L2 - n2 + 1
    End If
    Form1.MousePointer = 0
    mnMAX = mn
    CmdMain.Enabled = False
    If mn = 0 Then
        Exit Sub '
    End If
    DoEvents
    Mk '加分类标志、加行号、加“斜纹行”
    DoEvents
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Mk() '     加 '!'标志、加行号、加“斜纹行”
    Dim hh%, pp%, mn%, i%, j%, CCDD%
    'hh是左边的行号，  pp是右边的行号
    Dim kh$, Lkh$, Rkh$
    Dim L3%, xie%, a1&, s1&, txt3$(), TETOL$
    kh = "       ///////////////////////////////////////" & vbCrLf
    mn = 1:    hh = 1:    pp = 1
    Do
        If hh = QS(0, mn) And pp = QS(1, mn) Then '特殊行
            CCDD = CD(0, mn) - CD(1, mn)
            For i = 1 To Abs(CCDD)
                If CCDD > 0 Then
                    Rkh = Rkh & kh
                    xie = xie + 1
                Else
                    Lkh = Lkh & kh '/////////
                End If
            Next i
            For i = 0 To CD(0, mn) - 1
                LS(QS(0, mn) + i) = "! " & Right$("  " & Trim$(Str$(QS(0, mn) + i)), 3) & "  " & LS(QS(0, mn) + i)  '加!
            Next i
            hh = hh + i '左边的行号
            For j = 0 To CD(1, mn) - 1
                RS(QS(1, mn) + j) = "! " & Right$("  " & Trim$(Str$(QS(1, mn) + j)), 3) & "  " & RS(QS(1, mn) + j)  '加!
            Next j
            pp = pp + j '右边的行号
            If mn < mnMAX Then mn = mn + 1
        Else '非特殊行
            LS(hh) = "  " & Right$("  " & Trim$(Str$(hh)), 3) & "  " & LS(hh)
            LS(hh) = Lkh & LS(hh)
            Lkh = ""
            RS(pp) = "  " & Right$("  " & Trim$(Str$(pp)), 3) & "  " & RS(pp)
            RS(pp) = Rkh & RS(pp)
            Rkh = ""
            pp = pp + 1
            hh = hh + 1
        End If
    Loop Until hh > L1 And pp > L2
    LS(L1) = LS(L1) & vbCrLf & Lkh
    RS(L2) = RS(L2) & vbCrLf & Rkh
    tx1 = "": tx2 = ""
    For i = 1 To L1
        tx1 = tx1 & LS(i) & vbCrLf
    Next i
    For j = 1 To L2
        tx2 = tx2 & RS(j) & vbCrLf
    Next j
    Text1.Text = tx1: Text2.Text = tx2
    Label7.Visible = True
    L3 = L2 + xie
    ReDim txt3(L3), LS(L3), RS(L3)
    a1 = 1
    a1 = 1
    For i = 1 To L3
        s1 = InStr(a1, tx1, vbCrLf)
        LS(i) = Mid$(tx1, a1, s1 - a1)
        a1 = s1 + 2
    Next i
    a1 = 1
    For i = 1 To L3
        s1 = InStr(a1, tx2, vbCrLf)
        RS(i) = Mid$(tx2, a1, s1 - a1)
        a1 = s1 + 2
    Next i
    For j = 1 To L3
        TETOL = TETOL & LS(j) & Chr(9) & RS(j) & vbCrLf
    Next j
    Clipboard.Clear
    Clipboard.SetText TETOL

End Sub

[此贴子已经被作者于2025-1-2 14:48编辑过]