[已解决]VBA实现多表格竖向查找合并

jk0932 · 发表于 2015-4-8 14:28

本帖最后由 jk0932 于 2015-4-28 21:39 编辑

有若干个表格，首列都存在相同项目，每个表格有若干行，若干列，现在需要按照Book1的首列把其他表格中的内容进行查找到Book1中中，普通方法是粘贴表头，然后用vlookup查找，逐列对应，但很麻烦，
求VBA实现列合并，如附件所示

发现运行结果并未得到正确值；求更新

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-8 14:47

相同地区品种的累加为一列，原数据中有两列“河北”

Sub 导入文件()
Application.ScreenUpdating = False
Dim Filename, wb As Workbook, Sht As Worksheet
Filename = Dir(ThisWorkbook.Path & "\*.xlsx")
Set d = CreateObject("scripting.dictionary") '品种+地区
Set d1 = CreateObject("scripting.dictionary") '品种
Set d2 = CreateObject("scripting.dictionary") '地区
Do While Filename <> ""
If Filename <> ThisWorkbook.Name Then
fn = ThisWorkbook.Path & "" & Filename
Set wb = Workbooks.Open(fn)
Set Sht = wb.Worksheets(1)
arr = Sht.[a1].CurrentRegion
For j = 2 To UBound(arr, 2) '地区
If Len(arr(1, j)) > 0 Then d2(arr(1, j)) = ""
Next
For i = 2 To UBound(arr)
d1(arr(i, 1)) = "" '品种
For j = 2 To UBound(arr, 2)
x = arr(i, 1) & arr(1, j)
d(x) = d(x) + arr(i, j) '品种+地区，数量累加
Next
Next
wb.Close False
End If
Filename = Dir
Loop
Set Sht = Nothing
With Sheet1
.[a1].Resize(1, d2.Count) = d2.keys
.[a2].Resize(d1.Count) = Application.Transpose(d1.keys)
arr = .[a1].CurrentRegion
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
x = arr(i, 1) & arr(1, j)
arr(i, j) = d(x)
Next
Next
.[a1].CurrentRegion = arr
End With
Application.ScreenUpdating = True
End Sub

复制代码

跳转到最佳答案楼层

grf1973 · 发表于 2015-4-8 14:47

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

相同地区品种的累加为一列，原数据中有两列“河北”

Sub 导入文件()
Application.ScreenUpdating = False
Dim Filename, wb As Workbook, Sht As Worksheet
Filename = Dir(ThisWorkbook.Path & "\*.xlsx")
Set d = CreateObject("scripting.dictionary") '品种+地区
Set d1 = CreateObject("scripting.dictionary") '品种
Set d2 = CreateObject("scripting.dictionary") '地区
Do While Filename <> ""
If Filename <> ThisWorkbook.Name Then
fn = ThisWorkbook.Path & "" & Filename
Set wb = Workbooks.Open(fn)
Set Sht = wb.Worksheets(1)
arr = Sht.[a1].CurrentRegion
For j = 2 To UBound(arr, 2) '地区
If Len(arr(1, j)) > 0 Then d2(arr(1, j)) = ""
Next
For i = 2 To UBound(arr)
d1(arr(i, 1)) = "" '品种
For j = 2 To UBound(arr, 2)
x = arr(i, 1) & arr(1, j)
d(x) = d(x) + arr(i, j) '品种+地区，数量累加
Next
Next
wb.Close False
End If
Filename = Dir
Loop
Set Sht = Nothing
With Sheet1
.[a1].Resize(1, d2.Count) = d2.keys
.[a2].Resize(d1.Count) = Application.Transpose(d1.keys)
arr = .[a1].CurrentRegion
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
x = arr(i, 1) & arr(1, j)
arr(i, j) = d(x)
Next
Next
.[a1].CurrentRegion = arr
End With
Application.ScreenUpdating = True
End Sub

复制代码

jk0932 · 发表于 2015-4-14 22:20

grf1973 发表于 2015-4-8 14:47
相同地区品种的累加为一列，原数据中有两列“河北”

x = arr(i, 1) & arr(1, j) 第20行是什么意思？
d(x) = d(x) + arr(i, j) 第21行是如何实现的？

grf1973 · 发表于 2015-4-15 11:01

1、x = arr(i, 1) & arr(1, j) 第20行是什么意思？
答：把A列每个单元格和第1行每个单元格相连作为key。比如“苹果北京”“梨子河北”。。。。。
2、d(x) = d(x) + arr(i, j) 第21行是如何实现的？
答：各key所对应的数量累加。比如文件1“梨子河北”有100，文件2“梨子河北”有200，那么“梨子河北”所对应的数量就是100+200=300

jk0932 · 发表于 2015-4-28 21:38

grf1973 发表于 2015-4-8 14:47
相同地区品种的累加为一列，原数据中有两列“河北”

运行结果发现有问题，地区北京应该从A2开始，现在却在A1，问题结果如下：

北京	西安	河南	河北	山西	广东	广西	太原	成都
苹果	32	14	60	11	32	32	27	13
梨子	11	15	79	27	47	47	64	18
葡萄干	27	13	113	64	66	66	11	31
巴旦木	64	18	78	11	12	12	18	32
榴莲干	11	31	31	18	19	19	14	47
牡蛎	18	32	32	14	32	32	15	66
虾仁	14	47	110	15	47	47	13	12
豆腐干	15	66	62	19	66	66	18	19
牛肉干	13	12	116	13	12	12	31	11
马肉干	18	19	144	18	19	19	13	12
豆乳	31	11	131	17	14	18	18	19
鸡蛋	32	14	60	11	32	32	27	13
牛肉奶昔	11	15	79	27	47	47	64	18
羊奶	27	13	113	64	66	66	11	31
红豆	64	18	78	11	12	12	18	32
大米	11	31	31	18	19	19	14	47
库尔勒	18	32	32	14	32	32	15	66
哈密桃	14	47	110	15	47	47	13	12
芒果	15	66	62	19	66	66	18	19
西单	13	12	116	13	12	12	31	11
橘子品	18	19	144	18	19	19	13	12
雪莲	31	11	131	17	14	18	18	19
虎主	32	14	60	11	32	32	27	13
毛皮	11	15	79	27	47	47	64	18

grf1973 · 发表于 2015-4-29 13:50

惭愧惭愧，犯了点小错误。改过来了。

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