Question

我一直在寻找代码来确定两个选定单元格之间的区别，并将其显示在Excel 2010的状态栏中。

我找到了一些代码，但它只适用于包含该代码的工作簿。是否可以在我正在使用的每个工作簿上使此代码正常工作？如果这种代码像personal.xlsb中的宏一样自动运行会很棒。

Public Sub workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set sh = ActiveSheet
If Selection.Cells.Count = 2 Then
   On Error Resume Next
    If WorksheetFunction.Count(Range(Selection.Address)) = 2 Then
        Application.StatusBar = "The difference is " & _
        WorksheetFunction.Max(Range(Selection.Address)) _
        - WorksheetFunction.Min(Range(Selection.Address))
    Else
        Application.StatusBar = "The difference is " & _
        WorksheetFunction.Max(Range(Selection.Address))
    End If
Else
    Application.StatusBar = False
End If
End Sub

Answer 1

我找到了一些代码，但它只适用于包含该代码的工作簿。是否可以在我正在使用的每个工作簿上使此代码正常工作？

您必须为此创建一个加载项。然后将其放在加载项的ThisWorkbook模块中。创建加载项后，通过选中“开发人员”选项卡“加载项”部分的复选框来激活它。

Private WithEvents oXLApp As Excel.Application

Private Sub Workbook_Open()
    Set oXLApp = Excel.Application
End Sub

Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
    '
    '~~> Rest of the code here
    '
End Sub

Answer 2

这些问题产生了以下工具。

将以下项目另存为.xla

的ThisWorkbook：

Private WithEvents oXLApp As Excel.Application

Private Sub Workbook_Open()
    Set oXLApp = Excel.Application
End Sub

Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As range)

Dim limit As Long
limit = 300000 ' selection limit

Dim frmt As String
frmt = "#,##0;(#,##0);""-""" ' formating at status bar

' first condition - one selection area


If Selection.Areas.Count = 1 Then

On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
   On Error Resume Next
        Application.StatusBar = _
            "       D:    " & Format(WorksheetFunction.Max(Selection) - WorksheetFunction.Min(Selection), frmt) & _
            "       U:    " & Format(Unique(Selection), frmt) & _
            "       2X:    " & Format(WorksheetFunction.Sum(Selection) * 2, frmt) & _
            "       X2:    " & Format(WorksheetFunction.Sum(Selection) / 2, frmt) & _
            "       NC:    " & Format(WorksheetFunction.CountIf(Selection, "<0"), frmt) & _
            "       NS:    " & Format(WorksheetFunction.SumIf(Selection, "<0"), frmt)
Else


If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
   On Error Resume Next
        Application.StatusBar = False
    End If ' No condition
End If ' Cells > 2 and < limit
End If ' Areas = 1 - end of first condition


' second condition - more than one selection areas



If Selection.Areas.Count > 1 Then

Dim r1 As range
Dim r2 As range
Set r1 = Selection.Areas(1)
'WorksheetFunction.Sum (r1)
On Error Resume Next
Set r2 = Selection.Areas(2)
'Set multipleRange = Union(r1, r2)

On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
   On Error Resume Next
        Application.StatusBar = _
            "       D:    " & Format(DIFF(r1, r2), frmt) & _
            "       U:    " & Format(Unique(r1), frmt) & _
            "       2X:    " & Format(WorksheetFunction.Sum(r1) * 2, frmt) & _
            "       X2:    " & Format(WorksheetFunction.Sum(r1) / 2, frmt) & _
            "       NC:    " & Format(WorksheetFunction.CountIf(r1, "<0"), frmt) & _
            "       NS:    " & Format(WorksheetFunction.SumIf(r1, "<0"), frmt)
Else


If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
   On Error Resume Next
        Application.StatusBar = False
    End If ' no condition
End If ' Cells > 1
End If ' Areas > 1 - end of second condition

End Sub

第1单元：

Public Function DIFF(rng1 As range, rng2 As range)
   DIFF = WorksheetFunction.Sum(rng1) - WorksheetFunction.Sum(rng2)
End Function

第2单元：

Public Function Unique(ByRef rngToCheck As range) As Variant

    Dim colDistinct As Collection
    Dim varValues As Variant, varValue As Variant
    Dim lngCount As Long, lngRow As Long, lngCol As Long

    On Error GoTo ErrorHandler

    varValues = rngToCheck.Value

    'if rngToCheck is more than 1 cell then
   'varValues will be a 2 dimensional array
   If IsArray(varValues) Then

        Set colDistinct = New Collection

        For lngRow = LBound(varValues, 1) To UBound(varValues, 1)
            For lngCol = LBound(varValues, 2) To UBound(varValues, 2)

                varValue = varValues(lngRow, lngCol)

                'ignore blank cells and throw error
               'if cell contains an error value
               If LenB(varValue) > 0 Then

                    'if the item already exists then an error will
                   'be thrown which we want to ignore
                   On Error Resume Next
                    colDistinct.Add vbNullString, CStr(varValue)
                    On Error GoTo ErrorHandler

                End If

            Next lngCol
        Next lngRow

        lngCount = colDistinct.Count
    Else
        If LenB(varValues) > 0 Then
            lngCount = 1
        End If

    End If

    Unique = lngCount

    Exit Function

ErrorHandler:
    Unique = CVErr(xlErrValue)

End Function

显示excel状态栏中两个单元格之间的差异

2 个答案: