大佬们好久不见，能否帮忙

Qs18

Mr_Ying 发表于 2024-11-20 08:45
你好，谢谢你，读取数据是F3到F7的位置,F3=SUM(B3:E3),依次类推

好的，改一下

Qs18

1. Sub qs()
   
2. With Sheet6
   
3.    .[g3:o7] = Empty
   
4. For r = 3 To 7
   
5. 
   
6.     x = "￥" & Application.WorksheetFunction.Round(.Range("f" & r).Value * 100, 0)
   
7.    
   
8.     For i = 1 To Len(x)
   
9.          .Cells(r, 16 - i).Value = Left(Right(x, i), 1)
   
10.     Next
    
11. Next
    
12. x2 = x2 + Application.WorksheetFunction.Round(.Range("f7").Value * 100, 0)
    
13. a = [{18,16,14,12,10,8,6,4,2}]
    
14. For y = 1 To Len(x2)
    
15.     c = c + 1
    
16.     .Cells(8, a(c)).Value = zdxa(Left(Right(x2, y), 1))
    
17. Next
    
18. For i = c + 1 To UBound(a)
    
19.     .Cells(8, a(i)).Value = ChrW(&H2717)
    
20. Next
    
21. End With
    
22. End Sub
    
23. Function zdxa(x) '升级转数字人民币大写
    
24. Dim a
    
25. a = [{0,"零";1,"壹";2,"贰";3,"叁";4,"肆";5,"伍";6,"陆";7,"柒";8,"捌";9,"玖"}]
    
26. Set dic = CreateObject("scripting.dictionary")
    
27.     For i = 1 To UBound(a)
    
28.     dic(CStr(a(i, 1))) = a(i, 2)
    
29.     dic(a(i, 1)) = a(i, 2)
    
30.     Next
    
31. If dic.exists(x) Then
    
32.     zdxa = dic(x)
    
33. Else
    
34.     zdxa = x
    
35. End If
    
36. Set dic = Nothing
    
37. End Function

复制代码

Qs18

试试............

Qs18

试试...........

Mr_Ying

Qs18 发表于 2024-11-20 09:28
试试...........

能做成触发吗，当我在B3：E6输入时

Mr_Ying

Qs18 发表于 2024-11-19 17:31

再次感谢！结合用了一下AI，基本搞定！

Qs18

Mr_Ying 发表于 2024-11-20 09:32
能做成触发吗，当我在B3：E6输入时

不建议，如果用触发，那就直接用函数公式还不用写代码

Mr_Ying

1. 
   

复制代码

Mr_Ying

Qs18 发表于 2024-11-20 11:12
不建议，如果用触发，那就直接用函数公式还不用写代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim ws As Worksheet
   
3.     Dim i As Integer
   
4.     Dim j As Integer
   
5.     Dim rowTotal As Double
   
6.     Dim grandTotal As Double
   
7. 
   
8.     ' 设置工作表对象为当前工作表
   
9.     Set ws = Me
   
10. 
    
11.     ' 检查目标单元格是否在范围 B3:E6 内
    
12.     If Not Intersect(Target, ws.Range("B3:E6")) Is Nothing Then
    
13.         Application.EnableEvents = False ' 防止递归触发事件
    
14.         grandTotal = 0 ' 初始化总和变量
    
15. 
    
16.         ' 循环计算行总和 B3:E6，对应写入 F3:F6
    
17.         For i = 3 To 6
    
18.             rowTotal = 0
    
19.             For j = 2 To 5
    
20.                 rowTotal = rowTotal + ws.Cells(i, j).Value
    
21.             Next j
    
22.             ws.Cells(i, 6).Value = rowTotal ' 写入行总和到 F 列
    
23.             grandTotal = grandTotal + rowTotal ' 累加到总和
    
24.         Next i
    
25. 
    
26.         ' 写入整体总和到 F7
    
27.         ws.Cells(7, 6).Value = grandTotal
    
28.         Application.EnableEvents = True ' 重新启用事件
    
29.     End If
    
30.         If grandTotal > 0 Then
    
31.         Call qs
    
32.     End If
    
33. End Sub

复制代码

Qs18

Mr_Ying 发表于 2024-11-20 13:42

你太棒了