[已解决]一个单元格内多个数值同时乘以另外一个单元格数值；如何用VBA表达，谢谢

AcerQINGDAO

一个单元格内多个数值同时乘以另外一个单元格数值；如何用VBA表达，请楼主们赐教；谢谢
详见附件；

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2015-2-2 10:21

1. Sub lqxs()
   
2. Dim Arr, i&, Myr&, Brr
   
3. Dim d, t, a, be, wb$, gy$, s$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet2.Activate
   
7. Arr = Sheet3.[k1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     d(Arr(i, 1)) = Arr(i, 2) & "|" & Arr(i, 3)
   
10. Next
    
11. Myr = Cells(Rows.Count, 6).End(xlUp).Row
    
12. Brr = Range("a2:h" & Myr)
    
13. For i = 1 To UBound(Brr)
    
14.     If d.exists(Brr(i, 6)) Then
    
15.         t = d(Brr(i, 6))
    
16.         a = Split(t, "|")
    
17.         be = Brr(i, 8) / Val(a(0))
    
18.         wb = a(1): gy = "": s = ""
    
19.         If be > 1 Then
    
20.         For j = 1 To Len(wb)
    
21.             temp = Mid(wb, j, 1)
    
22.             If temp Like "[A-Za-z]" Then
    
23.                 If s = "" Then
    
24.                     gy = gy & temp
    
25.                 Else
    
26.                     gy = gy & Val(s) * be & temp: s = ""
    
27.                 End If
    
28.             Else
    
29.                 s = s & temp
    
30.             End If
    
31.         Next
    
32.         End If
    
33.         If s <> "" Then gy = gy & Val(s) * be
    
34.         Cells(i + 1, 3) = gy
    
35.     End If
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub
    

复制代码

跳转到最佳答案楼层

香川群子

没看懂楼主在附件里想要做什么。

就楼主标题来说，可以用录制宏记录复制某个单元格中的一个数值t，
然后对目标区域进行一次性全部运算（运算为：+-*/中的一种）的操作。

代码如下：

1. Sub Macro1()
   
2.     t = 4 '设定要统一运算的值t
   
3.     Range("IV1") = t '写入某个临时空单元格 如第1行最后1列（确保不影响其它有内容的单元格）
   
4.     Range("IV1").Copy '复制这个单元格得到值t
   
5.     Range("H2:H4").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd      '全部加运算
   
6.     Range("H2:H4").PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply  '全部乘运算
   
7.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract  '全部减运算
   
8.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide      '全部除运算
   
9.     Range("IV1") = "" '清空临时单元格
   
10.     Application.CutCopyMode = False '退出复制粘贴模式
    
11. End Sub

复制代码

香川群子

其实用数组循环更好：

1. Sub Macro2()
   
2.     t = 4    '设定要统一运算的值t
   
3.     ar = Range("H2:H4") '要计算的对象区域读入数组ar
   
4.     For i = 1 To UBound(ar) '遍历各行
   
5.         For j = 1 To UBound(ar, 2) '遍历各列
   
6.             ar(i, j) = ar(i, j) * t   '按需要进行运算
   
7.         Next
   
8.     Next
   
9.     Range("H2:H4") = ar '运算结果输出到工作表对象区域
   
10. End Sub

复制代码

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Myr&, Brr
   
3. Dim d, t, a, be, wb$, gy$, s$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet2.Activate
   
7. Arr = Sheet3.[k1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     d(Arr(i, 1)) = Arr(i, 2) & "|" & Arr(i, 3)
   
10. Next
    
11. Myr = Cells(Rows.Count, 6).End(xlUp).Row
    
12. Brr = Range("a2:h" & Myr)
    
13. For i = 1 To UBound(Brr)
    
14.     If d.exists(Brr(i, 6)) Then
    
15.         t = d(Brr(i, 6))
    
16.         a = Split(t, "|")
    
17.         be = Brr(i, 8) / Val(a(0))
    
18.         wb = a(1): gy = "": s = ""
    
19.         If be > 1 Then
    
20.         For j = 1 To Len(wb)
    
21.             temp = Mid(wb, j, 1)
    
22.             If temp Like "[A-Za-z]" Then
    
23.                 If s = "" Then
    
24.                     gy = gy & temp
    
25.                 Else
    
26.                     gy = gy & Val(s) * be & temp: s = ""
    
27.                 End If
    
28.             Else
    
29.                 s = s & temp
    
30.             End If
    
31.         Next
    
32.         End If
    
33.         If s <> "" Then gy = gy & Val(s) * be
    
34.         Cells(i + 1, 3) = gy
    
35.     End If
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. End Sub
    

复制代码

蓝桥玄霜

请见附件。

AcerQINGDAO

多谢蓝版主和香川群子的答复！谢谢

AcerQINGDAO

蓝版主好，
当“记录”中的数量为1时，不能生成。
请蓝版主再帮助看看，多谢