[已解决]各位老师,我有两个问题需要求教,请看附件中的表格,是否能解决!

VBA实学者

实例.rar (10.4 KB, 下载次数: 16)

2011-11-29 16:03 上传

点击文件名下载附件
请教各位老师帮我解决一下表内的两个问题,谢谢了
如有疑问请知悉一下我.

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-11-29 18:12

1. Sub jUSTtesT()
   
2.     Dim d As New Dictionary, Arr, ArrR(), i&, S$ '定义变量
   
3.     With Sheets("出库明细") '获取出库明细信息
   
4.         Arr = .Range("a1").CurrentRegion.Value
   
5.     End With
   
6.     For i = 3 To UBound(Arr) '货品及颜色信息存入字典项目，同时出库数量累加
   
7.         S = Arr(i, 3) & Arr(i, 4)
   
8.         d(S) = d(S) + Arr(i, 5)
   
9.     Next i
   
10.     Arr = Range("a4:h" & Cells(Rows.Count, 1).End(3).Row).Value
    
11.     '获取待生成数据信息
    
12.     ReDim ArrR(1 To UBound(Arr), 1 To 1) '重定义结果数组
    
13.     For i = 1 To UBound(Arr) '循环入库信息
    
14.         S = Arr(i, 3) & Arr(i, 4)
    
15.         If d.Exists(S) Then '如果货品颜色在字典项目中存在
    
16.             ArrR(i, 1) = Application.Min(Arr(i, 5), d(S)) '则返回出库信息
    
17.             d(S) = d(S) - ArrR(i, 1) '同时减少出库数量
    
18.         End If
    
19.     Next i
    
20.     Range("g4:g" & Rows.Count).ClearContents
    
21.     [g4].Resize(UBound(ArrR), 1) = ArrR
    
22. End Sub
    

复制代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not Application.Intersect(Target, [i1]) Is Nothing Then
   
3.     '判断是否更改了查询款号信息
   
4.         Dim Arr, i&, d As New Dictionary, ArrR(), k& '定义变量
   
5.         Arr = Range("a1").CurrentRegion.Value '获取款号数量信息入数组
   
6.         For i = 2 To UBound(Arr, 1) '循环数组
   
7.             If Arr(i, 1) = Target.Value Then '如果为查询款号记录
   
8.                 If Not d.Exists(Arr(i, 3)) Then '则颜色名称在字典项目中不存在，
   
9.                     k = k + 1: d.Add Arr(i, 3), k '累加颜色个数标识位，同时添加字典项目
   
10.                     ReDim Preserve ArrR(1 To 2, 1 To k) '同时动态定义结果数组
    
11.                 End If
    
12.                 ArrR(1, d(Arr(i, 3))) = Arr(i, 3) '对颜色所在的结果数组进行颜色赋值
    
13.                 ArrR(2, d(Arr(i, 3))) = Arr(i, 4) + ArrR(2, d(Arr(i, 3))) '对颜色所在的结果数组进行数量汇总
    
14.             End If
    
15.         Next i
    
16.         Range("f2:g" & Rows.Count).ClearContents '清空目标区域
    
17.         If k > 0 Then '如果有查询记录
    
18.             [f2].Resize(k, 2) = Application.Transpose(ArrR) '则返回结果
    
19.         End If
    
20.     End If
    
21. End Sub
    

复制代码

跳转到最佳答案楼层

liuguansky

第一问：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not Application.Intersect(Target, [i1]) Is Nothing Then
   
3.         Dim Arr, i&, d As New Dictionary, ArrR(), k&
   
4.         Arr = Range("a1").CurrentRegion.Value
   
5.         For i = 2 To UBound(Arr, 1)
   
6.             If Arr(i, 1) = Target.Value Then
   
7.                 If Not d.Exists(Arr(i, 3)) Then
   
8.                     k = k + 1: d.Add Arr(i, 3), k
   
9.                     ReDim Preserve ArrR(1 To 2, 1 To k)
   
10.                 End If
    
11.                 ArrR(1, d(Arr(i, 3))) = Arr(i, 3)
    
12.                 ArrR(2, d(Arr(i, 3))) = Arr(i, 4) + ArrR(2, d(Arr(i, 3)))
    
13.             End If
    
14.         Next i
    
15.         Range("f2:g" & Rows.Count).ClearContents
    
16.         If k > 0 Then
    
17.             [f2].Resize(k, 2) = Application.Transpose(ArrR)
    
18.         End If
    
19.     End If
    
20. End Sub
    

复制代码

第二问：

1. 
   
2. Sub jUSTtesT()
   
3.     Dim d As New Dictionary, Arr, ArrR(), i&, S$
   
4.     With Sheets("出库明细")
   
5.         Arr = .Range("a1").CurrentRegion.Value
   
6.     End With
   
7.     For i = 3 To UBound(Arr)
   
8.         S = Arr(i, 3) & Arr(i, 4)
   
9.         d(S) = d(S) + Arr(i, 5)
   
10.     Next i
    
11.     Arr = Range("a4:h" & Cells(Rows.Count, 1).End(3).Row).Value
    
12.     ReDim ArrR(1 To UBound(Arr), 1 To 1)
    
13.     For i = 1 To UBound(Arr)
    
14.         S = Arr(i, 3) & Arr(i, 4)
    
15.         If d.Exists(S) Then
    
16.             ArrR(i, 1) = Application.Min(Arr(i, 5), d(S))
    
17.             d(S) = d(S) - ArrR(i, 1)
    
18.         End If
    
19.     Next i
    
20.     Range("g4:g" & Rows.Count).ClearContents
    
21.     [g4].Resize(UBound(ArrR), 1) = ArrR
    
22. End Sub

复制代码

附件如下：
实例.rar (14.17 KB, 下载次数: 11)

2011-11-29 17:04 上传

点击文件名下载附件

若符合要求的话，金币就不用了，评个最佳就可以了。

VBA实学者

谢谢老师的精彩答案

VBA实学者

liuguansky 发表于 2011-11-29 16:04
第一问：

第二问：

你好,老师,有没有时间,能帮我解释一下这些代码的意思吗

liuguansky

1. Sub jUSTtesT()
   
2.     Dim d As New Dictionary, Arr, ArrR(), i&, S$ '定义变量
   
3.     With Sheets("出库明细") '获取出库明细信息
   
4.         Arr = .Range("a1").CurrentRegion.Value
   
5.     End With
   
6.     For i = 3 To UBound(Arr) '货品及颜色信息存入字典项目，同时出库数量累加
   
7.         S = Arr(i, 3) & Arr(i, 4)
   
8.         d(S) = d(S) + Arr(i, 5)
   
9.     Next i
   
10.     Arr = Range("a4:h" & Cells(Rows.Count, 1).End(3).Row).Value
    
11.     '获取待生成数据信息
    
12.     ReDim ArrR(1 To UBound(Arr), 1 To 1) '重定义结果数组
    
13.     For i = 1 To UBound(Arr) '循环入库信息
    
14.         S = Arr(i, 3) & Arr(i, 4)
    
15.         If d.Exists(S) Then '如果货品颜色在字典项目中存在
    
16.             ArrR(i, 1) = Application.Min(Arr(i, 5), d(S)) '则返回出库信息
    
17.             d(S) = d(S) - ArrR(i, 1) '同时减少出库数量
    
18.         End If
    
19.     Next i
    
20.     Range("g4:g" & Rows.Count).ClearContents
    
21.     [g4].Resize(UBound(ArrR), 1) = ArrR
    
22. End Sub
    

复制代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not Application.Intersect(Target, [i1]) Is Nothing Then
   
3.     '判断是否更改了查询款号信息
   
4.         Dim Arr, i&, d As New Dictionary, ArrR(), k& '定义变量
   
5.         Arr = Range("a1").CurrentRegion.Value '获取款号数量信息入数组
   
6.         For i = 2 To UBound(Arr, 1) '循环数组
   
7.             If Arr(i, 1) = Target.Value Then '如果为查询款号记录
   
8.                 If Not d.Exists(Arr(i, 3)) Then '则颜色名称在字典项目中不存在，
   
9.                     k = k + 1: d.Add Arr(i, 3), k '累加颜色个数标识位，同时添加字典项目
   
10.                     ReDim Preserve ArrR(1 To 2, 1 To k) '同时动态定义结果数组
    
11.                 End If
    
12.                 ArrR(1, d(Arr(i, 3))) = Arr(i, 3) '对颜色所在的结果数组进行颜色赋值
    
13.                 ArrR(2, d(Arr(i, 3))) = Arr(i, 4) + ArrR(2, d(Arr(i, 3))) '对颜色所在的结果数组进行数量汇总
    
14.             End If
    
15.         Next i
    
16.         Range("f2:g" & Rows.Count).ClearContents '清空目标区域
    
17.         If k > 0 Then '如果有查询记录
    
18.             [f2].Resize(k, 2) = Application.Transpose(ArrR) '则返回结果
    
19.         End If
    
20.     End If
    
21. End Sub
    

复制代码

VBA实学者

liuguansky 发表于 2011-11-29 18:12

真得太佩服你们了,我发现我爱上VBA了,再跟你说声谢谢

VBA实学者

liuguansky 发表于 2011-11-29 16:04
第一问：

第二问：

群主,你有没有开QQ交流群........??

wcg剑客

好好好