求助，vba实现 Excel导入外部表格数据

anxintong

【20190107XS01】【奥诺中国】报价：为订单表，文件名中的“20190107XS01”为订单号，这个是规定了，这样的订单文件  格式都是统一的
统计表：这个表格为，我打算做的一个数据总库。到时候实现所有的订单都能批量导入到这个   文件里。
说明：具体想实现的是，【20190107XS01】【奥诺中国】报价，表里面的染了黄颜色的单元格的内容均想导入到“统计表”里，我已经手动粘贴一部分数据。我想用vba实现一键导入的功能，最好能同时选多个文件一起导入。
请教高手帮忙啊

附件已上传

microyip

http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下

anxintong

microyip 发表于 2019-11-8 18:21
http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下

多谢

盼哥

1. Option Explicit
   
2. 
   
3.     Dim i&
   
4. Sub 导入()
   
5.    
   
6.     Dim maxRow&, p$, fName$
   
7.     With ThisWorkbook
   
8.         p = .Path
   
9.         With .ActiveSheet
   
10.             maxRow = .Cells(.Rows.Count, 4).End(xlUp).Row               'D列单元格的最大行
    
11.         End With
    
12.     End With
    
13.     Dim sBook As Workbook
    
14.     Dim fullName$, fileName$
    
15.     p = ThisWorkbook.Path
    
16.     fileName = Dir(p & "\*.xls*")
    
17.     Do While fileName <> ""
    
18.         If fileName <> ThisWorkbook.Name Then
    
19.             fullName = p & "\" & fileName
    
20.             Set sBook = Workbooks.Open(fullName)
    
21.             Call readExBook(sBook, maxRow)
    
22.             maxRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row               'D列单元格的最大行
    
23.         End If
    
24.         fileName = Dir
    
25.     Loop
    
26. End Sub
    
27. 
    
28. Sub readExBook(sBook, maxRow)
    
29.     Dim dataRowsCount&
    
30.     Dim arr, sArr, j&, k&
    
31.     With sBook.ActiveSheet
    
32.         dataRowsCount = WorksheetFunction.Max(.Range("B13:B26"))
    
33.         sArr = Range(sBook.ActiveSheet.Cells(13, "A"), sBook.ActiveSheet.Cells(13 + dataRowsCount - 1, "N"))
    
34.         ReDim arr(1 To dataRowsCount, 1 To [Z1].Column)
    
35.         For i = 1 To UBound(arr)
    
36.             arr(i, 1) = sArr(i, 1)      '编号
    
37.             arr(i, 2) = .Range("B1")    '订单号
    
38.             arr(i, 3) = .Range("K2")    '日期
    
39.             arr(i, 4) = .Range("B5")      '单位名称
    
40.             arr(i, 5) = .Range("B6")    '单位地址
    
41.             arr(i, 6) = .Range("E5")    '联系人
    
42.             arr(i, 7) = .Range("E6") '电话
    
43.             arr(i, [H1].Column) = .Range("E2")  '服务单位名称
    
44.             arr(i, [I1].Column) = .Range("I6")  '服务单位地址
    
45.             arr(i, [J1].Column) = .Range("N5")  '服务单位业务员
    
46.             
    
47.             '明细表
    
48.             For j = 3 To UBound(sArr, 2)
    
49.                 arr(i, [O1].Column + j - 3) = sArr(i, j)
    
50.             Next j
    
51.         Next i
    
52.         
    
53.     End With
    
54.     sBook.Close False
    
55.     ThisWorkbook.Sheets("数据库").Cells(maxRow + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
56. End Sub
    

复制代码

anxintong

盼哥 发表于 2019-11-9 07:58

此之大神，小生由此跪谢~~~~~

anxintong

盼哥 发表于 2019-11-9 07:58

美中略有不足的是，所要导入的文件得和  统计表在一个文件夹内，能不能  弄成，可以导入时，选取文件路径，而且可以同时选取多个文件，另外那个“编码”因为是唯一的，所以导入时如果发现，导入的文件内的编码与  统计表中已经存在的编码有重复的时候，能不能弹出个对话框，显示  有重复，并且停止导入。。。。神哥哥，，，

盼哥

anxintong 发表于 2019-11-9 16:10
美中略有不足的是，所要导入的文件得和  统计表在一个文件夹内，能不能  弄成，可以导入时，选取文件路径 ...

更多服务加Q继续