[已解决]请问老师，如何用宏模块做这张明细表？

liangyi1190

我的表有公式，但我想用VBA宏模块表示，不知老师可以帮我做到吗？谢谢！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2014-7-1 14:55

我这边打开是好的，原来的模块不需要了，你直接把下述代码放到“PF-11303”工作表模块里面就行了。
是工作表事件，你试一下效果

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Column <> 5 Then Exit Sub
   
3. If Target.Row < 6 Then Exit Sub
   
4. If Target.Count > 1 Then Exit Sub
   
5. If Target = "" Then Union(Target.Offset(, 1), Target.Offset(, 4).Resize(, 8)).ClearContents: Exit Sub
   
6. Dim arr, brr, r&
   
7. arr = Sheets(1).Range("b6:h" & Sheets(1).[b65536].End(3).Row)
   
8. brr = Target.Resize(, 15)
   
9. r = Target
   
10. brr(1, 2) = arr(r, 1)
    
11. brr(1, 8) = arr(r, 2) * IIf(brr(1, 5) = "L", 1, brr(1, 5)) * brr(1, 7) * 7.85 / 1000000
    
12. brr(1, 9) = brr(1, 4) * brr(1, 8)
    
13. brr(1, 10) = brr(1, 9) * arr(r, 4)
    
14. brr(1, 11) = arr(r, 3) * IIf(brr(1, 5) = "L", 1, brr(1, 5)) * brr(1, 7) / 1000000
    
15. brr(1, 12) = brr(1, 4) * brr(1, 11)
    
16. brr(1, 13) = brr(1, 12) * 13
    
17. brr(1, 15) = arr(r, 4) * IIf(brr(1, 9) = 0, brr(1, 4), brr(1, 9)) + brr(1, 12) * 13
    
18. Target.Resize(, 15) = brr
    
19. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

附件请测试，几个单独的简单的公式没有变动。

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, r&
   
3. arr = Sheets(1).Range("b6:h" & Sheets(1).[b65536].End(3).Row)
   
4. brr = Range("e6:s" & [c65536].End(3).Row)
   
5. For i = 1 To UBound(brr)
   
6.   If brr(i, 1) <> "" Then
   
7.     r = brr(i, 1)
   
8.     brr(i, 2) = arr(r, 1)
   
9.     brr(i, 8) = arr(r, 2) * IIf(brr(i, 5) = "L", 1, brr(i, 5)) * brr(i, 7) * 7.85 / 1000000
   
10.     brr(i, 9) = brr(i, 4) * brr(i, 8)
    
11.     brr(i, 10) = brr(i, 9) * arr(r, 4)
    
12.     brr(i, 11) = arr(r, 3) * IIf(brr(i, 5) = "L", 1, brr(i, 5)) * brr(i, 7) / 1000000
    
13.     brr(i, 12) = brr(i, 4) * brr(i, 11)
    
14.     brr(i, 13) = brr(i, 12) * 13
    
15.     brr(i, 15) = arr(r, 4) * IIf(brr(i, 9) = 0, brr(i, 4), brr(i, 9)) + brr(i, 12) * 13
    
16.   End If
    
17. Next i
    
18. [e6].Resize(UBound(brr), UBound(brr, 2)) = brr
    
19. End Sub

复制代码

liangyi1190

大灰狼1976 发表于 2014-6-27 23:01
附件请测试，几个单独的简单的公式没有变动。

老师你好！可否不用按钮，直接在E列中输入代码和我的公式一样，或直接在F列中输入代码返回值就是规格？谢谢

大灰狼1976

附件请测试

liangyi1190

大灰狼1976 发表于 2014-6-30 14:05
附件请测试

老师你好！这个模块没了{:041:}

su45

是不是想做成自定义函数？

大灰狼1976

我这边打开是好的，原来的模块不需要了，你直接把下述代码放到“PF-11303”工作表模块里面就行了。
是工作表事件，你试一下效果

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Column <> 5 Then Exit Sub
   
3. If Target.Row < 6 Then Exit Sub
   
4. If Target.Count > 1 Then Exit Sub
   
5. If Target = "" Then Union(Target.Offset(, 1), Target.Offset(, 4).Resize(, 8)).ClearContents: Exit Sub
   
6. Dim arr, brr, r&
   
7. arr = Sheets(1).Range("b6:h" & Sheets(1).[b65536].End(3).Row)
   
8. brr = Target.Resize(, 15)
   
9. r = Target
   
10. brr(1, 2) = arr(r, 1)
    
11. brr(1, 8) = arr(r, 2) * IIf(brr(1, 5) = "L", 1, brr(1, 5)) * brr(1, 7) * 7.85 / 1000000
    
12. brr(1, 9) = brr(1, 4) * brr(1, 8)
    
13. brr(1, 10) = brr(1, 9) * arr(r, 4)
    
14. brr(1, 11) = arr(r, 3) * IIf(brr(1, 5) = "L", 1, brr(1, 5)) * brr(1, 7) / 1000000
    
15. brr(1, 12) = brr(1, 4) * brr(1, 11)
    
16. brr(1, 13) = brr(1, 12) * 13
    
17. brr(1, 15) = arr(r, 4) * IIf(brr(1, 9) = 0, brr(1, 4), brr(1, 9)) + brr(1, 12) * 13
    
18. Target.Resize(, 15) = brr
    
19. End Sub

复制代码

liangyi1190

大灰狼1976 发表于 2014-7-1 14:55
我这边打开是好的，原来的模块不需要了，你直接把下述代码放到“PF-11303”工作表模块里面就行了。
是工作 ...

谢谢老师！我要认真学习

liangyi1190

liangyi1190 发表于 2014-7-1 19:17
谢谢老师！我要认真学习

请问老师，我的EXCEL2007为什么不能操作表格了？

liangyi1190

大灰狼1976 发表于 2014-7-1 14:55
我这边打开是好的，原来的模块不需要了，你直接把下述代码放到“PF-11303”工作表模块里面就行了。
是工作 ...

老师你好！请问此表为什么在EXCEL2007内不能运行呢？