[已解决]麻烦各位老师帮我看看，如何才能实现？

love_liwu

请教各位老师，现有《客户信息表》和《顾客信息》两个工作簿，根据同个区域代码和名称，自动匹配《客户信息表》的相关信息，填充到《顾客信息》即一个区域代码一张工作簿，如何实现？
数据源（假设有这么多，实际可能不止）：


效果图：（每个区域代码形成一个工作簿）
问题.zip (15.42 KB, 下载次数: 11)

2016-12-13 20:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-14 09:54

在“客户信息表”里点击按钮。

1. Sub 生成客户信息表()
   
2.     Dim sh As Worksheet, wb As Workbook
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
7.     Next
   
8.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
   
9.     Set sh = wb.Worksheets(1)
   
10.     For Each x In d.keys
    
11.         sh.Activate
    
12.         sh.Copy
    
13.         xrr = Split(d(x), ",")
    
14.         With ActiveSheet
    
15.             .[c4] = arr(xrr(1), 1)
    
16.             .[c5] = arr(xrr(1), 2)
    
17.             ReDim brr(1 To UBound(xrr), 3 To UBound(arr, 2))
    
18.             For i = 1 To UBound(xrr)
    
19.                 For j = 3 To UBound(arr, 2)
    
20.                     brr(i, j) = arr(xrr(i), j)
    
21.                 Next
    
22.             Next
    
23.             .[b7].Resize(i - 1, j - 3) = brr
    
24.         End With
    
25.         ActiveWorkbook.Close True, ThisWorkbook.Path & "\顾客信息-" & x
    
26.     Next
    
27.     wb.Close
    
28. End Sub
    

复制代码

跳转到最佳答案楼层

砂海

换言之 , 就是 增加内容以后 ,
根据  字段① 字段② 排序

love_liwu

砂海 发表于 2016-12-14 07:07
换言之 , 就是 增加内容以后 ,
根据  字段① 字段② 排序

不懂，请老师耐心指导，谢谢。

grf1973

在“客户信息表”里点击按钮。

1. Sub 生成客户信息表()
   
2.     Dim sh As Worksheet, wb As Workbook
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
7.     Next
   
8.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
   
9.     Set sh = wb.Worksheets(1)
   
10.     For Each x In d.keys
    
11.         sh.Activate
    
12.         sh.Copy
    
13.         xrr = Split(d(x), ",")
    
14.         With ActiveSheet
    
15.             .[c4] = arr(xrr(1), 1)
    
16.             .[c5] = arr(xrr(1), 2)
    
17.             ReDim brr(1 To UBound(xrr), 3 To UBound(arr, 2))
    
18.             For i = 1 To UBound(xrr)
    
19.                 For j = 3 To UBound(arr, 2)
    
20.                     brr(i, j) = arr(xrr(i), j)
    
21.                 Next
    
22.             Next
    
23.             .[b7].Resize(i - 1, j - 3) = brr
    
24.         End With
    
25.         ActiveWorkbook.Close True, ThisWorkbook.Path & "\顾客信息-" & x
    
26.     Next
    
27.     wb.Close
    
28. End Sub
    

复制代码

love_liwu

grf1973 发表于 2016-12-14 09:54
在“客户信息表”里点击按钮。

感谢老师耐心指导，谢谢@

emmahhm

来学习了