多个excel如何合并成一个，excel中的列不是完全相同，可能列的顺序不同

icedyb32

多个excel如何合并成一个，excel中的列不是完全相同，可能列的顺序不同，如何把相同的项合并到一列中，并且在每个excel中新增一列，把表名插入到那一列中

feiren228

每个表的字段数量必须相同，就是说不能缺项，顺序可以打乱。

1. Sub ado()
   
2.     Dim cnn As Object, rs As Object, sql$, ks&
   
3.     Dim bt, s$, mypath$, mynm$, myfile$, arr, j%, r&, bm$
   
4.     Set cnn = CreateObject("Adodb.Connection")
   
5.     Set rs = CreateObject("adodb.recordset")
   
6.     If Application.Version * 1 <= 11 Then
   
7.         cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
   
8.     Else
   
9.         cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
   
10.     End If
    
11.     With Sheets("汇总")
    
12.     .[a2:r60000] = ""
    
13.         arr = .[a1:q1]: s = arr(1, 1)
    
14.         For j = 2 To UBound(arr, 2)
    
15.             s = s & "," & arr(1, j)
    
16.         Next
    
17.         mypath = ThisWorkbook.Path & ""
    
18.         mynm = Dir(mypath & "*.xls")
    
19.         Do While mynm <> ""
    
20.             If mynm <> ThisWorkbook.Name Then
    
21.                 myfile = mypath & mynm
    
22.                 bm = Split(mynm, ".x")(0)
    
23.                 sql = "select " & s & " from [Excel 8.0;hdr=yes;Database=" & myfile & "].[" & bm & "$] where xm is not null"
    
24.                 'Debug.Print sql
    
25.                 Set rs = cnn.Execute(sql)
    
26.                 r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
    
27.                 .Range("a" & r).CopyFromRecordset rs
    
28.                 ks = r
    
29.                 r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
    
30.                 .Range("r" & ks).Resize(r - ks) = bm
    
31.             End If
    
32.             mynm = Dir
    
33.         Loop
    
34.     End With
    
35.     rs.Close: cnn.Close
    
36.     Set rs = Nothing
    
37.     Set cnn = Nothing
    
38. End Sub
    

复制代码

feiren228

。。。。。
test.zip (75.21 KB, 下载次数: 55)

2015-5-14 20:27 上传

点击文件名下载附件

张雄友

这样？？？？？？？？？？？

1. Sub GetData()
   
2.     Call Sum
   
3.     Dim arr, brr, crr, fileArr, d As Object
   
4.     Dim sht As Worksheet, sh As Worksheet, wd As Workbook
   
5.     Dim rng As Range
   
6.     Dim thePath$, i&, j&, n
   
7.     Set sh = ActiveSheet
   
8.     sh.UsedRange.Offset(1).ClearContents
   
9.     sh.Range("A1:C1") = Array("文件夹名", "工作簿名", "工作表名")
   
10.     arr = Range("A1").CurrentRegion
    
11.     Set d = CreateObject("Scripting.Dictionary")
    
12.     For i = 1 To UBound(arr, 2)
    
13.         d(arr(1, i)) = i
    
14.     Next
    
15.     With Application.FileDialog(msoFileDialogFolderPicker)
    
16.         .InitialFileName = ThisWorkbook.Path & ""
    
17.         If .Show = False Then Exit Sub
    
18.         thePath = .SelectedItems(1) & ""
    
19.     End With
    
20. 
    
21.     Application.ScreenUpdating = False
    
22.     Application.DisplayAlerts = False
    
23.     Application.Calculation = xlManual
    
24. 
    
25.     If Right(thePath, 1) <> "" Then thePath = thePath & ""
    
26.     ReDim brr(1 To 90000, 1 To UBound(arr, 2))
    
27.     fileArr = GetName(thePath)
    
28.     For k = 0 To UBound(fileArr)
    
29.         Set wb = Workbooks.Open(fileArr(k))
    
30.         For Each sht In wb.Worksheets
    
31.             Set rng = sht.Cells.Find("*")
    
32.             If Not rng Is Nothing Then
    
33.                 r = sht.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    
34.                 c = sht.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
35.                 crr = sht.Range(sht.Cells.Find("*", sht.Cells(Rows.Count, Columns.Count), , , xlByRows, xlNext), sht.Cells(r, c))
    
36.                 For i = 2 To UBound(crr)
    
37.                     x = x + 1
    
38.                     For j = 1 To UBound(crr, 2)
    
39.                         n = d(crr(1, j))
    
40.                         If n <> "" Then
    
41.                             m = 1
    
42.                             brr(x, 1) = Mid(wb.Path, InStrRev(wb.Path, "") + 1)
    
43.                             If Right(wb.Name, 4) = ".xls" Then brr(x, 2) = Left(wb.Name, Len(wb.Name) - 4) Else brr(x, 2) = Left(wb.Name, Len(wb.Name) - 5) '自动适用版本！！！
    
44.                             brr(x, 3) = sht.Name
    
45.                             brr(x, n) = crr(i, j)
    
46.                         End If
    
47.                     Next
    
48.                     If m = 0 Then x = x - 1
    
49.                     m = 0
    
50.                 Next
    
51.             End If
    
52.         Next
    
53.         wb.Close False
    
54.     Next
    
55.     sh.Range("A2").Resize(x, UBound(arr, 2)) = brr
    
56.     Application.ScreenUpdating = True
    
57.     Application.Calculation = xlAutomatic
    
58.     Application.DisplayAlerts = True
    
59.     MsgBox "OK！"
    
60. End Sub
    
61. 
    
62. Sub Sum()
    
63. Dim sh As Worksheet, arr, d As Object, i&, j&, MyPath$, Filepath, r&, c&
    
64. Cells.ClearContents
    
65. With Application.FileDialog(msoFileDialogFolderPicker)
    
66.     .InitialFileName = ThisWorkbook.Path & ""
    
67.     If .Show = False Then Exit Sub
    
68.     MyPath = .SelectedItems(1) & ""
    
69. End With
    
70. Application.ScreenUpdating = False
    
71. Set d = CreateObject("Scripting.Dictionary")
    
72. Filepath = GetName(MyPath)
    
73.     For kk = 0 To UBound(Filepath)
    
74.         Set wb = Workbooks.Open(Filepath(kk))
    
75.         For Each sh In wb.Sheets
    
76.             If Application.CountA(sh.UsedRange) Then
    
77.                         r = sh.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    
78.                         c = sh.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
79.                         arr = sh.Range(sh.Cells.Find("*", sh.Cells(Rows.Count, Columns.Count), , , xlByRows, xlNext), sh.Cells(r, c))
    
80.                     For j = 1 To UBound(arr, 2)
    
81.                         If Len(arr(1, j)) Then
    
82.                             If Not d.Exists(arr(1, j)) Then d(arr(1, j)) = ""
    
83.                         End If
    
84.                     Next
    
85.             End If
    
86.         Next
    
87.         wb.Close
    
88.     Next
    
89. Range("D1").Resize(, d.Count) = d.Keys
    
90. Application.ScreenUpdating = True
    
91. End Sub
    
92. 
    
93. Function GetName(lj As String)
    
94.     Dim MyName, dic, Did, i, t, F, tt, MyFileName
    
95.     Set dic = CreateObject("Scripting.Dictionary")
    
96.     Set Did = CreateObject("Scripting.Dictionary")
    
97.     dic.Add (lj), ""
    
98.     i = 0
    
99.     Do While i < dic.Count
    
100.         Ke = dic.Keys
     
101.         MyName = Dir(Ke(i), vbDirectory)
     
102.         Do While MyName <> ""
     
103.             If MyName <> "." And MyName <> ".." Then
     
104.                 If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
     
105.                     dic.Add (Ke(i) & MyName & ""), ""
     
106.                 End If
     
107.             End If
     
108.             MyName = Dir
     
109.         Loop
     
110.         i = i + 1
     
111.     Loop
     
112.     For Each Ke In dic.Keys
     
113.         MyFileName = Dir(Ke & "*.xls*")
     
114.         Do While MyFileName <> ""
     
115.             If MyFileName <> ThisWorkbook.Name Then Did.Add (Ke & MyFileName), ""
     
116.             MyFileName = Dir
     
117.         Loop
     
118.     Next
     
119.     GetName = Did.Keys
     
120. End Function
     
121. 
     

复制代码

icedyb32

feiren228 发表于 2015-5-14 20:27
。。。。。

用上次传的excel可以正常运行，但是excel文件多了以后，有问题，提示运行时错误‘-2147217904’，至少一个参数没有被指定值，我重新传一个附件，麻烦给看看什么原因吧

kszcs

张雄友 发表于 2015-5-14 21:01
这样？？？？？？？？？？？

各表字段不在一个行次的，也能筛选出来。留下

LMY123

ADO，同夹多薄首表合并
字段名相同，顺序不同