0

我正在寻找代码来确定两个选定单元格之间的差异并将其显示在 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
4

2 回答 2

2

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

您必须为此创建一个加载项。然后将其放入您的加载项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
于 2013-11-12T16:07:19.700 回答
0

这些问题导致了以下工具。

将以下项目另存为 .xla

本工作簿：

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

模块一：

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
于 2014-02-15T19:31:53.890 回答