[已解决]求助，关于按条件复制内容问题。。急。。

dcybt

想实现两表格按相同条件进行复制内容。根据规格。把表2中的数据汇总到表1.
表1

表2

1.rar (7 KB, 下载次数: 3)

2013-2-17 23:00 上传

点击文件名下载附件

急。。因为数据量很大。。谢谢了。。。

最佳答案

月排行榜 / 总排行榜

cbg2008

2013-2-17 23:54

dcybt 发表于 2013-2-17 23:21
能改成VBA吗。因为真实的表格有几万条。公式这样有点麻烦。。。。谢谢了。。

1. Sub Data_Analysis()
   
2.     On Error Resume Next
   
3.     Dim Arr_Output, Arr_Input, i&, j&, iRow&
   
4.     Dim D As Object
   
5.     Application.ScreenUpdating = False
   
6.     Arr_Input = Sheets("2表").UsedRange.Value
   
7.     Set D = CreateObject("Scripting.Dictionary")
   
8.     D.CompareMode = vbTextCompare
   
9.     For i = 2 To UBound(Arr_Input)
   
10.         D(Arr_Input(i, 2)) = i
    
11.     Next
    
12.     With Sheets("1表")
    
13.         Arr_Output = .UsedRange
    
14.         For i = 2 To UBound(Arr_Output)
    
15.             iRow = D(Arr_Output(i, 2))
    
16.             For j = 7 To 13
    
17.                 Arr_Output(i, j) = Arr_Input(iRow, j - 4)
    
18.             Next j
    
19.         Next i
    
20.         .Range("A1").Resize(UBound(Arr_Output), UBound(Arr_Output, 2)) = Arr_Output
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "已填写完毕！"
    
24. End Sub
    

复制代码

跳转到最佳答案楼层

cbg2008

=VLOOKUP($B2,'2表'!$B:$H,COLUMN(B1),0) 1.rar (11.03 KB, 下载次数: 7)

2013-2-17 23:12 上传

点击文件名下载附件

dcybt

cbg2008 发表于 2013-2-17 23:12
=VLOOKUP($B2,'2表'!$B:$H,COLUMN(B1),0)

能改成VBA吗。因为真实的表格有几万条。公式这样有点麻烦。。。。谢谢了。。

cbg2008

dcybt 发表于 2013-2-17 23:21
能改成VBA吗。因为真实的表格有几万条。公式这样有点麻烦。。。。谢谢了。。

1. Sub Data_Analysis()
   
2.     On Error Resume Next
   
3.     Dim Arr_Output, Arr_Input, i&, j&, iRow&
   
4.     Dim D As Object
   
5.     Application.ScreenUpdating = False
   
6.     Arr_Input = Sheets("2表").UsedRange.Value
   
7.     Set D = CreateObject("Scripting.Dictionary")
   
8.     D.CompareMode = vbTextCompare
   
9.     For i = 2 To UBound(Arr_Input)
   
10.         D(Arr_Input(i, 2)) = i
    
11.     Next
    
12.     With Sheets("1表")
    
13.         Arr_Output = .UsedRange
    
14.         For i = 2 To UBound(Arr_Output)
    
15.             iRow = D(Arr_Output(i, 2))
    
16.             For j = 7 To 13
    
17.                 Arr_Output(i, j) = Arr_Input(iRow, j - 4)
    
18.             Next j
    
19.         Next i
    
20.         .Range("A1").Resize(UBound(Arr_Output), UBound(Arr_Output, 2)) = Arr_Output
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "已填写完毕！"
    
24. End Sub
    

复制代码