完美Excel

Private Type Cell
    Value As String
    Address As String
End Type
Private Enum abOutputColumns
    abRange1Address = 1
    abRange1Value
    abRange2Address
    abRange2Value
End Enum

Public Sub OutputDifferences()
    On Error GoTo Err_Hnd
    Const strProcedureName_c As String = “AnalyzeDifferences”
    Const strTitleSelectRange_c As String = “选择单元格区域”
    Const strTitleError_c As String = “错误: “
    Const lngErrRngMismatch_c As Long = vbObjectError + 513
    Const lngErrCncl_c As Long = vbObjectError + 777
    Const lngErrIntrpt_c As Long = 18
    Const strErrRngMismatch_c As String = “您所选择的单元格区域大小不同.选择的单元格区域必须有相同的行数和相同的列数.”
    Const strErrCncl_c As String = “过程已取消.”
    Const lngMatch_c As Long = 0
    Const lngLwrBnd_c As Long = 1
    Const strFrcTxt_c As String = “‘”
    Const lngIncrement_c As Long = lngLwrBnd_c
    Const strBang_c As String = “!”
    Dim rng1 As Excel.Range
    Dim rng2 As Excel.Range
    Dim wbOutput As Excel.Workbook
    Dim wsOutput As Excel.Worksheet
    Dim lngRow As Long
    Dim lngClmn As Long
    Dim lngUprBndRow As Long
    Dim lngUprBndClmn As Long
    Dim lngOutputRow As Long
    Dim strWs1Name As String
    Dim strWs2Name As String
    Dim eCompareType As VbCompareMethod
    Dim tVal1 As Cell
    Dim tVal2 As Cell
     ”————————————————————————–
     ”选择要比较的单元格区域:—————————————————
     ”————————————————————————–
    Set rng1 = GetRange(”请使用鼠标选择第一个区域:”, strTitleSelectRange_c)
    If rng1 Is Nothing Then
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c
    End If
    Set rng2 = GetRange(”请使用鼠标选择第二个区域:”, strTitleSelectRange_c)
    If rng2 Is Nothing Then
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c
    End If
    lngUprBndRow = rng1.Rows.Count
    If lngUprBndRow <> rng2.Rows.Count Then
        VBA.Err.Raise lngErrRngMismatch_c, strProcedureName_c, strErrRngMismatch_c
    Else
        lngUprBndClmn = rng1.Columns.Count
        If lngUprBndClmn <> rng2.Columns.Count Then
            VBA.Err.Raise lngErrRngMismatch_c, strProcedureName_c, strErrRngMismatch_c
        End If
    End If
     ”—————————————————————————-
     ”提示用户是否区分大小写:—————————————————–
     ”—————————————————————————-
    Select Case VBA.MsgBox(”您想比较时区分大小写吗?”, vbYesNoCancel + vbQuestion + _
    vbSystemModal + vbDefaultButton2 + vbMsgBoxSetForeground, “确定比较类型”)
    Case VbMsgBoxResult.vbCancel
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c
    Case VbMsgBoxResult.vbYes
        eCompareType = vbBinaryCompare
    Case VbMsgBoxResult.vbNo
        eCompareType = vbTextCompare
    End Select
     ”============================================================================
    
     ”—————————————————————————-
     ‘所有对话框已结束,禁用界面为快速地执行:—————————————
     ”—————————————————————————-
    ToggleInterface False
     ”============================================================================
    
     ”—————————————————————————-
     ”创建输出工作表:————————————————————-
     ”—————————————————————————-
    Set wbOutput = Excel.Application.Workbooks.Add
    Set wsOutput = GetOutputSheet(wbOutput)
     ”============================================================================
    
     ”—————————————————————————-
     ”创建输出工作表:————————————————————-
     ”—————————————————————————-
    strWs1Name = rng1.Parent.Name & strBang_c
    strWs2Name = rng2.Parent.Name & strBang_c
    lngOutputRow = lngIncrement_c
     ”============================================================================
    
    
    For lngRow = lngLwrBnd_c To lngUprBndRow
        For lngClmn = lngLwrBnd_c To lngUprBndClmn
            tVal1.Value = CStr(rng1.Cells(lngRow, lngClmn).Value)
            tVal1.Address = CStr(rng1.Cells(lngRow, lngClmn).Address)
            tVal2.Value = CStr(rng2.Cells(lngRow, lngClmn).Value)
            tVal2.Address = CStr(rng2.Cells(lngRow, lngClmn).Address)
            If VBA.LenB(tVal1.Value) = VBA.LenB(tVal2.Value) Then
                 ‘如果长度相同,那么数值仍然可以是不同的.
                If VBA.StrComp(tVal1.Value, tVal2.Value, eCompareType) <> lngMatch_c Then
                    lngOutputRow = lngOutputRow + lngIncrement_c
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Address).Value = strFrcTxt_c & strWs1Name & tVal1.Address
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Value).Value = strFrcTxt_c & tVal1.Value
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Address).Value = strFrcTxt_c & strWs2Name & tVal2.Address
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Value).Value = strFrcTxt_c & tVal2.Value
                End If
            Else
                 ‘如果长度不同,那么所提供的数值是不同的.
                lngOutputRow = lngOutputRow + lngIncrement_c
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Address).Value = strFrcTxt_c & strWs1Name & tVal1.Address
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Value).Value = strFrcTxt_c & tVal1.Value
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Address).Value = strFrcTxt_c & strWs2Name & tVal2.Address
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Value).Value = strFrcTxt_c & tVal2.Value
            End If
        Next
    Next
    wsOutput.Columns.AutoFit
Exit_Proc:
    On Error Resume Next
    ToggleInterface True
    Exit Sub
Err_Hnd:
    If VBA.Err.Number = lngErrCncl_c Then
        Resume Exit_Proc
    ElseIf VBA.Err.Number = lngErrIntrpt_c Then
        VBA.MsgBox “Operation Cancelled”, vbOKOnly + vbMsgBoxSetForeground + vbSystemModal
    Else
        VBA.MsgBox VBA.Err.Description, vbCritical + vbMsgBoxHelpButton + vbMsgBoxSetForeground + _
        vbSystemModal, strTitleError_c & VBA.Err.Number, VBA.Err.HelpFile, VBA.Err.HelpContext
    End If
    On Error Resume Next
    If Not wbOutput Is Nothing Then
        wbOutput.Close False
    End If
    GoTo Exit_Proc
End Sub

Private Function GetRange(Prompt As String, Title As String) As Excel.Range
    On Error Resume Next
    Const lngRange_c As Long = 8
    Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c)
End Function