Question

我使用excel电子表格分析各种错误和欺诈数据。在处理数据时，我必须检查各种条件，如：

某个范围内有多少个单元格具有负值且
他们的金额是多少
范围内有多少个唯一值或
两个数字之间的差异是否太大......

在继续工作和每次打字之前，我必须进行这些微不足道的检查公式很耗时。因此，我创建了一个使用自定义公式的加载项，并在状态栏中显示结果。在图片中看到它的外观。

enter image description here

这个状态栏扩展插件大大简化了工作，我相信它对会计师，审计员，分析师和其他许多人都很有用..但是有一些我无法解决的缺点：

与原生的Excel状态栏功能不同，它非常慢。在我的PC上，选择100,000个单元格需要大约1/3秒才能处理，而“原生”平均或求和函数会立即显示结果。
加载项不适用于已过滤的范围。如果我过滤一个范围并选择它，我仍然会看到结果，好像细胞没有被过滤一样。 “原生”excel状态栏功能仅计算过程（可见）的数据。
此外，我想添加一个自定义函数，例如负数WorksheetFunction.CountIf(Selection, "<0")，但会计算范围内的excel错误（#NA！，＃REF！..）。
< / LI>

请参阅下面的加载项代码。值得一提的是，我是在stackoverflow用户和vba论坛参与者的帮助下编写的。非常感谢大家！

那么，伙计们，您能帮助我优化这个插件并为其添加新功能吗？

下面的VBA应保存为.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

第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加载项

0 个答案: