请老师帮写份VBA代码，

yimeier5

tanghanping2011 发表于 2024-9-5 20:37
谢谢老师！

当“y11”没有“困气1~5"时，也就是当”y11“是空白的时候，”y10“要回复为原” 45 “ ...

感觉用IFS函数实现功能会更快吧，下面代码你再试试吧

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim vLookupResult As Variant
   
3.     Dim multiplier As Double
   
4.     Dim multipliers As Variant
   
5.     Dim i As Long
   
6.     Dim dict As Object
   
7.       
   
8.     ' 当 DZ9 更改时
   
9.     If Not Intersect(Target, Me.Range("DZ9")) Is Nothing Then
   
10.         Application.EnableEvents = False
    
11.         On Error GoTo ErrorHandler
    
12.         
    
13.         Set dict = CreateObject("Scripting.Dictionary")
    
14.         multipliers = Array("困气1", 0.8, "困气2", 0.6, "困气3", 0.4, "困气4", 0.2, "困气5", 0.1)
    
15.         For i = LBound(multipliers) To UBound(multipliers) Step 2
    
16.             dict(multipliers(i)) = multipliers(i + 1)
    
17.         Next i
    
18.          
    
19.         vLookupResult = Application.WorksheetFunction.VLookup(Me.Range("BQ7").Value, ThisWorkbook.Sheets("胶料性能表").Range("$A$1:$AA$416"), 20, False)
    
20.         If dict.exists(Me.Range("Y11").Value) Then
    
21.             multiplier = dict(Me.Range("Y11").Value)
    
22.             Me.Range("Y10").Value = vLookupResult * multiplier
    
23.         Else
    
24.             Me.Range("Y10").Value = vLookupResult
    
25.         End If
    
26.          
    
27.         Application.EnableEvents = True
    
28.         Exit Sub
    
29.     End If
    
30.       
    
31.     ' 当 Y11 更改时
    
32.     If Not Intersect(Target, Me.Range("Y11")) Is Nothing Then
    
33.         Application.EnableEvents = False
    
34.         On Error GoTo ErrorHandler
    
35.          
    
36.         Set dict = CreateObject("Scripting.Dictionary")
    
37.         multipliers = Array("困气1", 0.8, "困气2", 0.6, "困气3", 0.4, "困气4", 0.2, "困气5", 0.1)
    
38.         For i = LBound(multipliers) To UBound(multipliers) Step 2
    
39.             dict(multipliers(i)) = multipliers(i + 1)
    
40.         Next i
    
41.          
    
42.         vLookupResult = Application.WorksheetFunction.VLookup(Me.Range("BQ7").Value, ThisWorkbook.Sheets("胶料性能表").Range("$A$1:$AA$416"), 20, False)
    
43.          
    
44.         If dict.exists(Me.Range("Y11").Value) Then
    
45.             multiplier = dict(Me.Range("Y11").Value)
    
46.             Me.Range("Y10").Value = vLookupResult * multiplier
    
47.         Else
    
48.             Me.Range("Y10").Value = vLookupResult
    
49.         End If
    
50.          
    
51.         Application.EnableEvents = True
    
52.         Exit Sub
    
53.     End If
    
54.       
    
55.     Exit Sub
    
56.       
    
57. ErrorHandler:
    
58.     MsgBox "发生错误: " & err.Description
    
59.     Application.EnableEvents = True
    
60. End Sub
    

复制代码

yimeier5

更新的代码

yimeier5

更新的代码

tanghanping2011

yimeier5 发表于 2024-9-6 14:03
更新的代码

太谢谢老师了，非常好用！！！

tanghanping2011

Qs18 发表于 2024-9-5 21:25
再试试...........

成形工艺表格.rar (230.49 KB, 下载次数: 1)

2024-9-13 12:42 上传

点击文件名下载附件

老师：还是这份表，功能增加如下，请帮抽时间再给修改下！谢谢您！

在EXCEL工作表中，当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“困气1”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别乘以0.8，（单元格中数字是
用函数命令“(VLOOKUP($BQ$7,胶料性能表!$A$1:$AA$416,20,FALSE))”引用的可变量的数字，
当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“困气2”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别乘以0.6，当Y11，AD11，AI11，AN11，AS11，
AX11，BC11，分别等于“困气3”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格
中数字分别乘以0.4，当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“困气4”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别乘以0.2，当Y11，AD11，
AI11，AN11，AS11，AX11，BC11，分别等于“困气5”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别乘以0.1，
但当Y11，AD11，AI11，AN11，AS11，AX11，BC11单元格“空白”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别等于原函数引用的数字。
当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“冲气1”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别除以0.8，（单元格中数字是
用函数命令“(VLOOKUP($BQ$7,胶料性能表!$A$1:$AA$416,20,FALSE))”引用的可变量的数字，
当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“冲气2”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别除以0.6，当Y11，AD11，AI11，AN11，AS11，
AX11，BC11，分别等于“冲气3”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格
中数字分别除以0.4，当Y11，AD11，AI11，AN11，AS11，AX11，BC11，分别等于“冲气4”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别除以0.2，当Y11，AD11，
AI11，AN11，AS11，AX11，BC11，分别等于“冲气5”时，Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别除以0.1，
但当Y11，AD11，AI11，AN11，AS11，AX11，BC11单元格“空白”时，
Y10，AD10，AI10，AN10，AS10，AX10，BC10单元格中数字分别等于原函数引用的数字。

Qs18

tanghanping2011 发表于 2024-9-13 12:45
老师：还是这份表，功能增加如下，请帮抽时间再给修改下！谢谢您！

在EXCEL工作表中，当Y11， ...

我试试看，您这个数据太杂乱了。求帮助不需要把工作中的数据一股脑的传上来，只需要模拟一些逻辑相似的数据即可。

Qs18

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Application.ScreenUpdating = False
   
3. Dim ss
   
4. If Target.Address(0, 0) <> "Y11" Then Exit Sub
   
5. Application.EnableEvents = False
   
6. 
   
7. Dim arr, ii, d2 As Object
   
8. Set d2 = CreateObject("scripting.dictionary")
   
9. arr = Sheet7.UsedRange.Value
   
10. For ii = 2 To UBound(arr)
    
11.     ss = arr(ii, 1)
    
12.     If Len(ss) > 1 Then
    
13.         If Not d2.exists(ss) Then
    
14.             d2(ss) = Array(arr(ii, 20), arr(ii, 21), arr(ii, 22), arr(ii, 23), arr(ii, 24), arr(ii, 25), arr(ii, 26))
    
15.         End If
    
16.     End If
    
17. Next
    
18. 
    
19. br = [{"Y10"，"AD10"，"AI10"，"AN10"，"AS10"，"AX10"，"BC10"}]
    
20. Dim ar, i, dic
    
21. 
    
22. Set dic = CreateObject("scripting.dictionary")
    
23. ar = [{"困气1","*0.8";"困气2","*0.6";"困气3","*0.4";"困气4","*0.2";"困气5","*0.1";"冲气1","/0.8";"冲气2","/0.6";"冲气3","/0.4";"冲气4","/0.2";"冲气5","/0.1"}]
    
24. For i = 1 To UBound(ar)
    
25.     dic(ar(i, 1)) = ar(i, 2)
    
26. Next
    
27. tt = Sheet1.[BQ7].Value
    
28. k = d2(tt)
    
29. If Target.Value = "" Then
    
30. 
    
31. 
    
32. For col = 0 To UBound(k)
    
33.     Sheet1.Range(br(col + 1)).Value = k(col)
    
34. Next
    
35. Else
    
36. s = Sheet1.Range("y11").Value
    
37. t = dic(s) '找出ar数组的系数
    
38. 
    
39. For col = 0 To UBound(k)
    
40. 
    
41.     Sheet1.Range(br(col + 1)).Value = Evaluate(k(col) & t)
    
42. Next
    
43. End If
    
44. Application.EnableEvents = True
    
45. Application.ScreenUpdating = True
    
46. End Sub

复制代码

Qs18

没有全部理解您的意思，应该是个大概，事件判断只在一个黄色单元格中，其他的自己加一下

Qs18

没有全部理解您的意思，应该是个大概，事件判断只在一个黄色单元格中，其他的自己加一下

tanghanping2011

Qs18 发表于 2024-9-13 14:43
没有全部理解您的意思，应该是个大概，事件判断只在一个黄色单元格中，其他的自己加一下

抱歉老师，我没有描述清楚，给您添麻烦了。
附件试了，不会计算。

见下图描述：感谢了。