[已解决]跨工作薄自动对应复制

grf1973

1. Sub 打开指定文件()          '用文件选择界面打开文件
   
2.     Dim Fil
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     Set wb = Workbooks.Open(Fil)        '打开文件
   
7.     Set sh = wb.Sheets(1)
   
8.     arr = sh.[a1].CurrentRegion
   
9.     wb.Close False
   
10.     ReDim brr(1 To UBound(arr), 1 To 5)
    
11.     For i = 2 To UBound(arr)
    
12.         n = n + 1
    
13.         brr(n, 1) = n
    
14.         brr(n, 2) = arr(i, 2)
    
15.         brr(n, 3) = arr(i, 4)
    
16.         brr(n, 4) = arr(i, 7)
    
17.         brr(n, 5) = arr(i, 8)
    
18.     Next
    
19.     [a5].Resize(n, 5) = brr
    
20. End Sub
    

复制代码

grf1973

请看附件。

qhllqhll

grf1973 发表于 2015-11-17 14:47
请看附件。

首先感谢您的帮助！
我有个想法您看看能否作到，假如弄来的信息源表里的姓名列不在现在的列，（也就是所在列位不固定），能否作成自动筛选来到对号入座，这可能很难，请你有时间的话帮我作作，再次感谢了！

mqr66

直接复制和粘贴不就完了。还搞得这么复杂。

mqr66

qhllqhll 发表于 2015-11-17 17:19
首先感谢您的帮助！
我有个想法您看看能否作到，假如弄来的信息源表里的姓名列不在现在的列，（也就是所 ...

为什么信息表里的姓名不在现在的列呢？一句话，复制和粘贴很容易做到的事，不用搞得这么复杂得。

qhllqhll

mqr66 发表于 2015-11-17 19:27
为什么信息表里的姓名不在现在的列呢？一句话，复制和粘贴很容易做到的事，不用搞得这么复杂得。

也就是姓名列或性别列的排列是不固定的
见图1

qhllqhll

谢谢各位了
复制出来的结果是不一样的

grf1973

1. Sub 打开指定文件()          '用文件选择界面打开文件
   
2.     Dim Fil
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     Set wb = Workbooks.Open(Fil)        '打开文件
   
7.     Set sh = wb.Sheets(1)
   
8.     arr = sh.[a1].CurrentRegion
   
9.     wb.Close False
   
10.    
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     For j = 1 To UBound(arr, 2)        '信息源的表头内容和列号相关联
    
13.         d(arr(1, j)) = j
    
14.     Next
    
15.     brr = Range("a3:e" & UBound(arr) + 4)
    
16.     For i = 2 To UBound(arr)
    
17.         brr(i, 1) = i - 1
    
18.         brr(i, 2) = arr(i, d(brr(1, 2)))
    
19.         brr(i, 3) = arr(i, d(brr(1, 3)))
    
20.         brr(i, 4) = arr(i, d(brr(1, 4)))
    
21.         brr(i, 5) = arr(i, d(brr(1, 5)))
    
22.     Next
    
23.     [a3].Resize(UBound(brr), 5) = brr
    
24. End Sub
    

复制代码

qhllqhll

grf1973 发表于 2015-11-17 14:47
请看附件。

首先感谢您的帮助！
我有个想法您看看能否作到，假如弄来的信息源表里的姓名列不在现在的列，（也就是所在列位不固定），能否作成自动筛选来到对号入座，这可能很难，请你有时间的话帮我作作，再次感谢了！

qhllqhll

grf1973 发表于 2015-11-18 09:49

谢谢，我现在在外面稍后测试，非常感谢