vba中根据另外一张表匹配单元格内容，并统计结果

Cosseven · 发表于 2015-9-27 13:39

本帖最后由 Cosseven 于 2015-9-28 09:50 编辑

各位老师好，有一张工作簿，内含“库存”，“机型”，“汇总”三张表，现在希望“库存”表最后增加一列，然后根据“库存”表中“商品”这个字段的内容在“机型”表中匹配填充“备注”的内容，实现在“汇总”表中根据备注内容对“数量”这列进行汇总，不同公司的数量。另外再汇总相应商品在不同公司的数量。
目前我是一步一步用数据透视表进行最后的汇总的，自己录制的宏因表格的列的变化就不好用了，想请教下用VBA如何实现。详细表格见附件，感谢指点。

Cosseven · 发表于 2015-9-27 16:00

求指点，各位老师

huang1314wei · 发表于 2015-9-27 17:02

Sub 汇总()
Dim arr, brr, i%, j%, d, d1
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
Erase arr: j = Sheet1.Range("A1048576").End(xlUp).Row
arr = Sheet1.Range("A3:N" & j)
For i = 2 To UBound(arr)
If d.exists(arr(i, 7)) Then
arr(i, 14) = d(arr(i, 7))
d1(d(arr(i, 7))) = ""
End If
Next
d.RemoveAll
Sheet1.Range("N3").Resize(UBound(arr)) = Application.Index(arr, 0, 14)
For i = 2 To UBound(arr)
If arr(i, 14) <> "" Then
If Not d.exists(arr(i, 4)) Then
Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
d(arr(i, 4))(arr(i, 14)) = arr(i, 9)
Else
d(arr(i, 4))(arr(i, 14)) = d(arr(i, 4))(arr(i, 14)) + arr(i, 9)
End If
End If
Next
Rows("2:1048576").Clear
Range("A2").Resize(d1.Count) = Application.Transpose(d1.keys)
brr = Range("A1").CurrentRegion
On Error Resume Next
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
brr(i, j) = d(brr(1, j))(brr(i, 1))
Next
Next
Range("A1").CurrentRegion = brr
End Sub

复制代码

huang1314wei · 发表于 2015-9-27 17:03

附件参考：

求教.rar (130.22 KB, 下载次数: 89)

Cosseven · 发表于 2015-9-27 17:13

huang1314wei 发表于 2015-9-27 17:02

再请教下，我想在汇总表里同时实现统计库存表里的不同的商品，应该如何修改呢

huang1314wei · 发表于 2015-9-27 17:26

Cosseven 发表于 2015-9-27 17:13
再请教下，我想在汇总表里同时实现统计库存表里的不同的商品，应该如何修改呢

Sub 汇总()
Dim arr, brr, i%, j%, d
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
j = Sheet1.Range("A1048576").End(xlUp).Row
arr = Sheet1.Range("A3:N" & j)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 4)) Then
Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
d(arr(i, 4))(arr(i, 7)) = arr(i, 9)
d1(arr(i, 7)) = ""
Else
d1(arr(i, 7)) = ""
d(arr(i, 4))(arr(i, 7)) = d(arr(i, 4))(arr(i, 7)) + arr(i, 9)
End If
Next
Rows("2:1048576").Delete
Range("A2").Resize(d1.Count) = Application.Transpose(d1.keys)
brr = Range("A1").CurrentRegion
On Error Resume Next
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
brr(i, j) = d(brr(1, j))(brr(i, 1))
Next
Next
Range("A1").CurrentRegion = brr
End Sub

复制代码

Cosseven · 发表于 2015-9-27 17:32

huang1314wei 发表于 2015-9-27 17:26

再请教下，如果是指定的商品呢

zax010 · 发表于 2015-9-27 17:40

Sub zz()
Dim d1, d2, ar, br
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
ar = Sheet1.Range("A3").CurrentRegion
br = Sheet2.Range("A1").CurrentRegion
For i = 2 To UBound(br)
      d1(br(i, 1)) = br(i, 2)
Next
For i = 4 To UBound(ar)
      If ar(i, 7) = "MOTO-G" Then
         d2(ar(i, 7) & ar(i, 4)) = d2(ar(i, 7) & ar(i, 4)) + ar(i, 9)
      End If
      If d1.exists(ar(i, 7)) Then
         ar(i, 7) = d1(ar(i, 7))
         d2(ar(i, 7) & ar(i, 4)) = d2(ar(i, 7) & ar(i, 4)) + ar(i, 9)
      End If
Next
With Sheet3
      For i = 2 To 5
         For j = 2 To 23
            .Cells(i, j) = d2(.Cells(i, 1).Value & .Cells(1, j).Value)
         Next
      Next
End With
Application.ScreenUpdating = True
End Sub

zax010 · 发表于 2015-9-27 17:43

>>>>>>>>>>>>>>>>>>>>>>>>>

求教.rar (136.93 KB, 下载次数: 47)

huang1314wei · 发表于 2015-9-27 17:43

Cosseven 发表于 2015-9-27 17:32
再请教下，如果是指定的商品呢

请指定啥商品

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

[已解决] vba中根据另外一张表匹配单元格内容，并统计结果

评分

评分

评分