请老师帮写份VBA代码，

Qs18 · 发表于 2024-9-13 17:08

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("Y11:BC11")) Is Nothing Then
Application.ScreenUpdating = False
Dim ss
Application.EnableEvents = False
Dim arr, ii, d2 As Object, d3
Set d2 = CreateObject("scripting.dictionary")
arr = Sheet7.UsedRange.Value
For ii = 2 To UBound(arr)
ss = arr(ii, 1)
If Len(ss) > 1 Then
If Not d2.exists(ss) Then
d2(ss) = Array(arr(ii, 20), arr(ii, 21), arr(ii, 22), arr(ii, 23), arr(ii, 24), arr(ii, 25), arr(ii, 26))
End If
End If
Next
Set d3 = CreateObject("scripting.dictionary")
br = [{"Y10"，"AD10"，"AI10"，"AN10"，"AS10"，"AX10"，"BC10"}]
For x = 1 To UBound(br)
d3(Left(br(x), 2)) = x - 1
Next
Dim ar, i, dic, s
Set dic = CreateObject("scripting.dictionary")
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"}]
For i = 1 To UBound(ar)
dic(ar(i, 1)) = ar(i, 2)
Next
tt = Sheet1.[BQ7].Value
k = d2(tt)
If Target.Value = "" Then
dz = Target.Address(0, 0)
If dz = "Y11" Then
Range("y10").Value = k(0)
ElseIf dz = "AD11" Then
Range("AD10").Value = k(1)
ElseIf dz = "AI11" Then
Range("AI10").Value = k(2)
ElseIf dz = "AN11" Then
Range("AN10").Value = k(3)
ElseIf dz = "AS11" Then
Range("AS10").Value = k(4)
ElseIf dz = "AX11" Then
Range("AX10").Value = k(5)
ElseIf dz = "BC11" Then
Range("BC10").Value = k(6)
End If
Else
s = Target.Value
t = dic(s) '找出ar数组的系数
yy = Left(Target.Address(0, 0), 2)
col = d3(yy)
Target.Offset(-1).Value = Evaluate(k(col) & t)
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub

复制代码

Qs18 · 发表于 2024-9-13 17:09

tanghanping2011 发表于 2024-9-13 15:30
抱歉老师，我没有描述清楚，给您添麻烦了。
附件试了，不会计算。

我现在理解到的是分别控制，对应关系

Qs18 · 发表于 2024-9-13 17:14

试试。。。。。。。。。

Qs18 · 发表于 2024-9-13 17:15

试试。。。。。。。

tanghanping2011 · 发表于 2024-9-13 21:12

Qs18 发表于 2024-9-13 17:15
试试。。。。。。。

感谢老师，计算功能都正确了

但是在Y11，AD11，AI11，AN11，AS11，AX11，BC11都是空白时，我切换材料时，对应的Y10，AD10，AI10，AN10，AS10，AX10，BC10的引用数字
不会自动跟着变动，需要我把每一个空格重新按一次才变化，请您再帮我看下。给老师添麻烦了

谢谢老师！！！

Qs18 · 发表于 2024-9-13 21:26

tanghanping2011 发表于 2024-9-13 21:12
感谢老师，计算功能都正确了
但是在Y11，AD11，AI11，AN11，AS11，AX11，BC11都是空白 ...

你这个适合用按钮，用事件不是很合适

Qs18 · 发表于 2024-9-14 08:27

Sub qs()
Application.ScreenUpdating = False
Dim ss, s, arr, ii, d2 As Object, tt, jj, k
Dim ar, i, dic
Set d2 = CreateObject("scripting.dictionary")
arr = Sheet7.UsedRange.Value
For ii = 2 To UBound(arr)
ss = arr(ii, 1)
If Len(ss) > 1 Then
If Not d2.exists(ss) Then
For jj = 20 To 26
If arr(ii, jj) = Empty Then
arr(ii, jj) = 0
End If
Next
d2(ss) = Array(arr(ii, 20), arr(ii, 21), arr(ii, 22), arr(ii, 23), arr(ii, 24), arr(ii, 25), arr(ii, 26))
End If
End If
Next
br = [{"Y11"，"AD11"，"AI11"，"AN11"，"AS11"，"AX11"，"BC11"}]
Set dic = CreateObject("scripting.dictionary")
ar = [{"","*1";"困气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"}]
For i = 1 To UBound(ar)
dic(ar(i, 1)) = ar(i, 2)
Next
tt = Sheet1.[BQ7].Value
k = d2(tt)
For i = 1 To UBound(br)
s = Sheet1.Range(br(i)).Value
t = dic(s) '找出ar数组的系数
Sheet1.Range(br(i)).Offset(-1).Value = Evaluate(k(i - 1) & t)
Next
Set dic = Nothing: Set d2 = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("Y11:BC11,DZ9")) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
Call qs
Application.EnableEvents = True
End If
End Sub

复制代码

Qs18 · 发表于 2024-9-14 08:39

试试。。。。。。。。。。

Qs18 · 发表于 2024-9-14 08:40

试试。。。。。。。。。

tanghanping2011 · 发表于 2024-9-14 09:30

Qs18 发表于 2024-9-14 08:40
试试。。。。。。。。。

太感谢！！！
谢谢老师

		自动登录	找回密码
密码			免费注册

[求助] 请老师帮写份VBA代码，

评分

评分