[已解决]如何用VBA将登记表的数据导入另一张汇总表内

KDZ

      各们大师：请教如何用VBA实现将一张表的数据导入另一张内，具体要求，请祥见汇总表，先行谢谢大师了，祝您2017好运来！！！！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-8 15:36

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim brr(1 To 1000, 1 To 13)
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets(1)
    
11.             arr = Sht.Range("a1:k" & Sht.[c65536].End(3).Row)
    
12.             wb.Close False
    
13.             For i = 4 To UBound(arr)
    
14.                 If arr(i, 2) <> "" Then
    
15.                     xm = arr(i, 3)  '家主姓名
    
16.                     sfz = arr(i, 4) '家主身份证
    
17.                 End If
    
18.                 n = n + 1
    
19.                 brr(n, 1) = xm
    
20.                 brr(n, 3) = sfz
    
21.                 brr(n, 5) = arr(i, 3)
    
22.                 brr(n, 13) = arr(i, 4)
    
23.             Next
    
24.         End If
    
25.         Filename = Dir
    
26.     Loop
    
27.     Set Sht = Nothing
    
28.     [I2].Resize(n, 13) = brr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

跳转到最佳答案楼层

十五的月亮

用技巧也很简单。

KDZ

您好，因为有数千行的数据，用函数不方便，，请编个VBA，谢谢老师。

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim brr(1 To 1000, 1 To 13)
   
6.     Do While Filename <> ""
   
7.         If Filename <> ThisWorkbook.Name Then
   
8.             fn = ThisWorkbook.Path & "" & Filename
   
9.             Set wb = Workbooks.Open(fn)
   
10.             Set Sht = wb.Worksheets(1)
    
11.             arr = Sht.Range("a1:k" & Sht.[c65536].End(3).Row)
    
12.             wb.Close False
    
13.             For i = 4 To UBound(arr)
    
14.                 If arr(i, 2) <> "" Then
    
15.                     xm = arr(i, 3)  '家主姓名
    
16.                     sfz = arr(i, 4) '家主身份证
    
17.                 End If
    
18.                 n = n + 1
    
19.                 brr(n, 1) = xm
    
20.                 brr(n, 3) = sfz
    
21.                 brr(n, 5) = arr(i, 3)
    
22.                 brr(n, 13) = arr(i, 4)
    
23.             Next
    
24.         End If
    
25.         Filename = Dir
    
26.     Loop
    
27.     Set Sht = Nothing
    
28.     [I2].Resize(n, 13) = brr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码