[已解决]两个工作表之间数据转换

YUANXMJYPX

  各位 老师 大师 大神们  早上好!
           我想利用VBA来处理同一工作簿中两个工作表之间数据转换的问题,即将一个工作表中的"供应商"对应的"付款金额"自动分摊到另外一个工作表对应的"供应商"的各条记录中的"申请付款A"中,详见附件说明,这样的程序对经常使用EXCEL的朋友来说是一件有益的好事,只要能实现该功能,我相信会有许多人感谢各位老师的,在此,我首先非常非常感谢各位的帮助和支持!

最佳答案

月排行榜 / 总排行榜

dsmch

2015-9-11 12:50

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, drr, d, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Sheet2.Activate
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Range("a5").CurrentRegion
   
7. ReDim crr(1 To UBound(brr) - 4, 1 To 1)
   
8. ReDim drr(1 To UBound(brr) - 4, 1 To 1)
   
9. For i = 2 To UBound(arr)
   
10.     d(arr(i, 1)) = arr(i, 17)
    
11. Next
    
12. For i = 6 To UBound(brr)
    
13.     If d(brr(i, 6)) = 0 Then GoTo line100
    
14.     If d(brr(i, 6)) >= brr(i, 19) Then
    
15.         crr(i - 5, 1) = brr(i, 19)
    
16.         d(brr(i, 6)) = d(brr(i, 6)) - brr(i, 19)
    
17.     Else
    
18.         crr(i - 5, 1) = d(brr(i, 6)): d(brr(i, 6)) = 0
    
19.     End If
    
20.     If crr(i - 5, 1) > 0 Then drr(i - 5, 1) = Format(crr(i - 5, 1) / brr(i, 19), "0.00%")
    
21. line100:
    
22. Next
    
23. Range("t6").Resize(UBound(crr)) = crr
    
24. Range("v6").Resize(UBound(drr)) = drr
    
25. End Sub

复制代码

dsmch

………………

YUANXMJYPX

老师 你好 ！
       增加的判断内容，见重新上传的附件， 款项处理.zip (21.84 KB, 下载次数: 5)

2015-9-13 19:53 上传

点击文件名下载附件

YUANXMJYPX

满足了我上传资料所给出的条件,故我设置为：”答案最佳“,再次谢谢 dsmch 朋友！