挑战性问题！表头顺序不同（但表头字段相同）的多个表格如何汇总？着急！感谢大神！

KCFONG

see if help you
Put all files under the same folder

jbjbzjb

fdkjfkdjfkjakfjdkjfkjda

事后补：
1.汇总记录工作簿中的汇总表表头字段位置可任意；
2.汇总记录工作簿中的汇总表表头字段数可增减，但至少保证5个，因为判断目标工作表的依据是同一行至少5个字段名相同；

张雄友

jbjbzjb 发表于 2014-3-9 11:39
fdkjfkdjfkjakfjdkjfkjda

事后补：

是合并工作表吧？表头不是自动生成的？

张雄友

KCFONG 发表于 2014-3-8 23:55
see if help you
Put all files under the same folder

the answer in columns(a:a) is wrong.all rows are 453.but your are 524?

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim cnn As New ADODB.Connection
   
4.   Dim rs As New ADODB.Recordset
   
5.   Dim sql$, mybook$, mysheet$, mypath$, wjm$
   
6.   Dim arr
   
7.   Dim wb As Workbook
   
8.   Dim ws0 As Worksheet
   
9.   Dim ws As Worksheet
   
10.   Dim i%, r0%, r%
    
11.   
    
12.   Application.DisplayAlerts = False
    
13.   mybook = ThisWorkbook.FullName
    
14.   
    
15.   With cnn
    
16.     .Provider = "microsoft.jet.oledb.4.0"
    
17.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
    
18.     .Open
    
19.   End With
    
20.   
    
21.   mypath = ThisWorkbook.Path & ""
    
22.   wjm = Dir(mypath & "*.xls")
    
23.   
    
24.   Do While wjm <> ""
    
25.     If wjm <> "汇总数据.xls" Then
    
26.       d(wjm) = ""
    
27.     End If
    
28.     wjm = Dir()
    
29.   Loop
    
30.   
    
31.   kk = d.Keys
    
32.   d.RemoveAll
    
33.   
    
34.   For i = 0 To UBound(kk)
    
35.     sql = "select * from [Excel 8.0;database=" & mypath & kk(i) & "].[sheet1$]"
    
36.     rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
37.     For j = 0 To rs.Fields.Count - 1
    
38.       d(rs.Fields(j).Name) = ""
    
39.     Next
    
40.     rs.Close
    
41.   Next
    
42.   
    
43.   For Each aa In d.Keys
    
44.     If aa Like "F#" Or aa Like "F##" Then
    
45.       d.Remove aa
    
46.     End If
    
47.   Next
    
48.   
    
49.   m = 1
    
50.   For Each aa In d.Keys
    
51.     d(aa) = m
    
52.     m = m + 1
    
53.   Next
    
54.   
    
55.   With ThisWorkbook.Worksheets("sheet1")
    
56.     .Cells.Delete
    
57.     .Range("a1").Resize(1, d.Count) = d.Keys
    
58.   End With
    
59.   
    
60.   Set ws0 = ThisWorkbook.Worksheets("sheet1")
    
61.   For i = 0 To UBound(kk)
    
62.     Set wb = GetObject(mypath & kk(i))
    
63.     With ws0
    
64.       r0 = .Range("a1").CurrentRegion.Rows.Count
    
65.     End With
    
66.     With wb
    
67.       With .Worksheets(1)
    
68.         c = .Cells(1, Columns.Count).End(xlToLeft).Column
    
69.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
70.         For j = 1 To c
    
71.           .Cells(2, j).Resize(r - 1, 1).Copy ws0.Cells(r0 + 1, d(.Cells(1, j).Value))
    
72.         Next
    
73.       End With
    
74.     End With
    
75.     wb.Close
    
76.   Next
    
77.          
    
78.   cnn.Close
    
79.   Set fso = Nothing
    
80.   Set rs = Nothing
    
81.   Set cnn = Nothing
    
82.   Application.DisplayAlerts = True
    
83. End Sub
    

复制代码

张雄友

chxw68 发表于 2014-3-9 16:19

Dim rs As New ADODB.Recordset

需要引用哪个？

chxw68

采用ADO+SQL的办法自动提取各表表头取重以后自动生成汇总表格表头，然后按照Dsmch老师的办法，逐一打开要汇总的工作薄，逐列依次拷入汇总表的对应列，这样就不用考虑工作表表头全不全的问题了。
原打算使用ADO+SQL的INSETR INTO语句读取、写入汇总数据，但由于要汇总的工作表表头字段名中含有空格等字符没有成功。

chxw68

张雄友 发表于 2014-3-9 16:23
Dim rs As New ADODB.Recordset

需要引用哪个？

引用“Microsoft ActiveX Datea Objects 2.8 Library”

张雄友

chxw68 发表于 2014-3-9 16:30
引用“Microsoft ActiveX Datea Objects 2.8 Library”

sql = "select * from [Excel 8.0;database=" & mypath & kk(i) & "].[sheet1$]"

是不是只可以合并所有工作簿的sheet1，如有sheet2，sheet3就不行了？

KCFONG

张雄友 发表于 2014-3-9 15:58
the answer in columns(a:a) is wrong.all rows are 453.but your are 524?

you had 2 SHIPPER NAME column in dec.01&02.2007.xls (column A and column C)
???