一个财务小功能：选中区域和值的自动复制粘贴

aoe1981

学习了，整理代码如下：

1. Dim s$, t#
   
2. Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   
3.     If ActiveCell = "" Then ActiveCell = t Else ActiveCell = s
   
4. End Sub
   
5. Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
   
6.     If Target.Count = 1 Then Exit Sub Else Cancel = True
   
7.     With New DataObject '接管剪切板
   
8.         .SetText "=SUM(" & Selection.Address(0, 0) & ")"
   
9.         .PutInClipboard
   
10.     End With
    
11.     t = WorksheetFunction.Sum(Selection)
    
12.     s = "=SUM(" & Selection.Address(0, 0) & ")"
    
13.     Application.StatusBar = Format(t, "#,###.00 ") & s '设置状态栏信息
    
14. End Sub

复制代码

发现鼠标右键被接管了。
这真是一个很有创意的程序。

aoe1981

7楼附件学习整理：
ThisWorkbook事件代码：

1. Private Sub Workbook_BeforeClose(Cancel As Boolean)
   
2.     Application.OnKey "^c"
   
3. End Sub
   
4. Private Sub Workbook_Open()
   
5.     Application.OnKey "^c", "myNumberCopy"
   
6. End Sub

复制代码

模块代码：

1. Sub myNumberCopy()
   
2.     Dim t, s
   
3.     With New DataObject
   
4.         .SetText "=SUM(" & Selection.Address(0, 0) & ")"
   
5.         .PutInClipboard
   
6.     End With
   
7.     t = WorksheetFunction.Sum(Selection)
   
8.     s = "=SUM(" & Selection.Address(0, 0) & ")"
   
9.     Application.StatusBar = Format(t, "#,###.00 ") & s
   
10. End Sub

复制代码

真不错，很有意思。

YZC51

跟各位老师学习。谢谢老师们！
实现功能：直接粘贴数值！！！
财务快捷求和操作.rar (31.68 KB, 下载次数: 23)

2019-12-3 08:15 上传

点击文件名下载附件

YZC51

学习老师的代码。谢谢老师！
可以多表格内使用粘贴功能。
Public t, s, aa

Public Sub 求和()
    With New DataObject
        t = Application.Sum(Selection)
        s = Application.CountA(Selection)
        .SetText t
        .PutInClipboard
    End With
    ss = Round(s, 2): tt = Round(t, 2):   aa = Round(t / s, 2)
    Application.StatusBar = "平均值：  " & aa & "    计数：  " & ss & "    求和：  " & tt
End Sub

YZC51

学习老师的代码。谢谢老师！
财务快捷求和.zip (33.7 KB, 下载次数: 44)

2019-12-3 08:13 上传

点击文件名下载附件

summeren

YZC51 发表于 2019-12-3 08:13
学习老师的代码。谢谢老师！

犀利，不知道是否可以实现双击右键 才实现该功能，避免全选等操作。发现为空时建议加入一个判断会出错；

summeren

YZC51 发表于 2019-12-3 08:13
学习老师的代码。谢谢老师！

改成如下代码，但是感觉双击右键时会弹出右键，有时候会失效；

Public clicknum, delay_time

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    clicknum = clicknum + 1
    delay_time = Now()
    If clicknum = 2 And Now() - delay_time < 1 Then
        If Target.CountLarge = 1 Then Exit Sub Else Cancel = True
        Call 求和
    Else
        Cancel = False
        clicknum = 1
    End If
End Sub

Public t, s, aa

Public Sub 求和()
On Error Resume Next
    With New DataObject
        t = Application.Sum(Selection)
        s = Application.CountA(Selection)
        .SetText t
        .PutInClipboard
    End With
    SS = Round(s, 2): tt = Round(t, 2):   aa = Round(t / s, 2)
    Application.StatusBar = "平均值：  " & aa & "    计数：  " & SS & "    求和：  " & tt
    clicknum = 0
End Sub

YZC51

谢谢老师指教！学习啦！
Public t, s, aa

Public Sub 求和()
    With New DataObject
        t = Application.Sum(Selection)
        s = Application.CountA(Selection)
        .SetText t
        .PutInClipboard
    End With
    If s > 0 Then
        ss = Round(s, 2):  tt = Round(t, 2): aa = Round(t / s, 2)
        Application.StatusBar = "平均值：  " & aa & "    计数：  " & ss & "    求和：  " & tt
    Else
        Application.StatusBar = ""
    End If
End Sub

月关

YZC51

月关 发表于 2019-12-3 15:52

老师谬赞啦！学生感觉很惭愧！