[已解决]SQL至少一个参数没有指定值

张雄友

SQL至少一个参数没有指定值。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-11-16 21:51

1. Sub 合并数据()    '目的在于合并指定文件夹中的工作簿数据！
   
2.     Dim cnn As Object, rs As Object, rst As Object, d As Object, ds As Object, k
   
3.     Dim SQL$, Mypath$, MyFile$, s$, m&, n&, i%, j&, l&, arrf(), arr(), temp$, strField$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         Mypath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Set ds = CreateObject("scripting.dictionary")
    
12.     Cells.ClearContents
    
13.     MyFile = Dir(Mypath & "*.xls?")
    
14.     Do While MyFile <> ""
    
15.         If MyFile <> ThisWorkbook.Name Then
    
16.             Set cnn = CreateObject("ADODB.Connection")
    
17.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
18.             Set rst = cnn.OpenSchema(20)    'adSchemaTables
    
19.             Do Until rst.EOF
    
20.                 If rst.Fields("TABLE_TYPE") = "TABLE" Then
    
21.                     s = Replace(rst("TABLE_NAME").Value, "'", "")
    
22.                     If Right(s, 1) = "$" Then
    
23.                         Set rs = cnn.Execute("[" & s & "]")
    
24.                         If Left(rs.Fields(0).Name, 1) <> "F" And Not IsNumeric(Mid(rs.Fields(0).Name, 2)) Then
    
25.                             n = n + 1
    
26.                             ReDim Preserve arrf(1 To n)
    
27.                             arrf(n) = "[Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]"
    
28.                             strField = ""
    
29.                             For i = 0 To rs.Fields.Count - 1    '历遍每个工作表的每个字段(判断列数不等的依据)
    
30.                                 temp = rs.Fields(i).Name
    
31.                                 If Left(temp, 1) <> "F" And Not IsNumeric(Mid(temp, 2)) Then    '排除其他可能的空字段
    
32.                                     If Len(temp) Then
    
33.                                         If Not d.Exists(temp) Then d(temp) = ""    '字段名写入字典
    
34.                                     End If
    
35.                                     strField = strField & temp & ","    '字段名用逗号连接
    
36.                                     ds(arrf(n)) = strField & ","    '工作簿名与工作表名连接添加到字典ds键值，字段名连接字符串添加到字典条目
    
37.                                 End If
    
38.                             Next
    
39.                         End If
    
40.                     End If
    
41.                 End If
    
42.                 rst.MoveNext
    
43.             Loop
    
44.         End If
    
45.         MyFile = Dir()
    
46.     Loop
    
47.     k = d.Keys
    
48.     [a1].Resize(, d.Count) = k
    
49.     For l = 1 To n Step 49
    
50.         m = 0
    
51.         For i = l To l + 48
    
52.             If i > n Then Exit For
    
53.             m = m + 1
    
54.             ReDim Preserve arr(1 To m)
    
55.             For j = 0 To UBound(k)    '逐个不重复字段
    
56.                 If InStr("," & ds(arrf(i)), "," & k(j) & ",") Then     '该工作表存在该字段
    
57.                     arr(m) = arr(m) & "," & k(j)
    
58.                 Else
    
59.                     arr(m) = arr(m) & ",'' as " & k(j)  '该工作表不存在该字段要添加 '' as 字段
    
60.                 End If
    
61.             Next
    
62.             arr(m) = "select " & Mid(arr(m), 2) & " from " & arrf(i) & ""
    
63.         Next
    
64.         SQL = Join(arr, " union all ")
    
65.         Erase arr
    
66.         Range("a" & Range("A1").CurrentRegion.Rows.Count + 1).CopyFromRecordset cnn.Execute(SQL)
    
67.     Next
    
68.     rs.Close
    
69.     rst.Close
    
70.     cnn.Close
    
71.     Set rs = Nothing
    
72.     Set rst = Nothing
    
73.     Set cnn = Nothing
    
74.     Application.ScreenUpdating = True
    
75.     MsgBox "查询完成"
    
76. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 合并数据()    '目的在于合并指定文件夹中的工作簿数据！
   
2.     Dim cnn As Object, rs As Object, rst As Object, d As Object, ds As Object, k
   
3.     Dim SQL$, Mypath$, MyFile$, s$, m&, n&, i%, j&, l&, arrf(), arr(), temp$, strField$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         Mypath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Set ds = CreateObject("scripting.dictionary")
    
12.     Cells.ClearContents
    
13.     MyFile = Dir(Mypath & "*.xls?")
    
14.     Do While MyFile <> ""
    
15.         If MyFile <> ThisWorkbook.Name Then
    
16.             Set cnn = CreateObject("ADODB.Connection")
    
17.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
18.             Set rst = cnn.OpenSchema(20)    'adSchemaTables
    
19.             Do Until rst.EOF
    
20.                 If rst.Fields("TABLE_TYPE") = "TABLE" Then
    
21.                     s = Replace(rst("TABLE_NAME").Value, "'", "")
    
22.                     If Right(s, 1) = "$" Then
    
23.                         Set rs = cnn.Execute("[" & s & "]")
    
24.                         If Left(rs.Fields(0).Name, 1) <> "F" And Not IsNumeric(Mid(rs.Fields(0).Name, 2)) Then
    
25.                             n = n + 1
    
26.                             ReDim Preserve arrf(1 To n)
    
27.                             arrf(n) = "[Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]"
    
28.                             strField = ""
    
29.                             For i = 0 To rs.Fields.Count - 1    '历遍每个工作表的每个字段(判断列数不等的依据)
    
30.                                 temp = rs.Fields(i).Name
    
31.                                 If Left(temp, 1) <> "F" And Not IsNumeric(Mid(temp, 2)) Then    '排除其他可能的空字段
    
32.                                     If Len(temp) Then
    
33.                                         If Not d.Exists(temp) Then d(temp) = ""    '字段名写入字典
    
34.                                     End If
    
35.                                     strField = strField & temp & ","    '字段名用逗号连接
    
36.                                     ds(arrf(n)) = strField & ","    '工作簿名与工作表名连接添加到字典ds键值，字段名连接字符串添加到字典条目
    
37.                                 End If
    
38.                             Next
    
39.                         End If
    
40.                     End If
    
41.                 End If
    
42.                 rst.MoveNext
    
43.             Loop
    
44.         End If
    
45.         MyFile = Dir()
    
46.     Loop
    
47.     k = d.Keys
    
48.     [a1].Resize(, d.Count) = k
    
49.     For l = 1 To n Step 49
    
50.         m = 0
    
51.         For i = l To l + 48
    
52.             If i > n Then Exit For
    
53.             m = m + 1
    
54.             ReDim Preserve arr(1 To m)
    
55.             For j = 0 To UBound(k)    '逐个不重复字段
    
56.                 If InStr("," & ds(arrf(i)), "," & k(j) & ",") Then     '该工作表存在该字段
    
57.                     arr(m) = arr(m) & "," & k(j)
    
58.                 Else
    
59.                     arr(m) = arr(m) & ",'' as " & k(j)  '该工作表不存在该字段要添加 '' as 字段
    
60.                 End If
    
61.             Next
    
62.             arr(m) = "select " & Mid(arr(m), 2) & " from " & arrf(i) & ""
    
63.         Next
    
64.         SQL = Join(arr, " union all ")
    
65.         Erase arr
    
66.         Range("a" & Range("A1").CurrentRegion.Rows.Count + 1).CopyFromRecordset cnn.Execute(SQL)
    
67.     Next
    
68.     rs.Close
    
69.     rst.Close
    
70.     cnn.Close
    
71.     Set rs = Nothing
    
72.     Set rst = Nothing
    
73.     Set cnn = Nothing
    
74.     Application.ScreenUpdating = True
    
75.     MsgBox "查询完成"
    
76. End Sub

复制代码

uceadf

select 日期,制单号,订单数量,预期计划,收益,'' as 工号,'' as 姓名,'' as 交飞,'' as 人事,'' as 组别1,'' as 组别2,'' as 款号,'' as 工序号,'' as 工序名称,'' as 代码,'' as 单价,数量,'' as 收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet1$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet10$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet100$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet11$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,
组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet12$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet13$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet14$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet15$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet16$] uni
on all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet17$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet18$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet19$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet2$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,
收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet20$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet21$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet22$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet23$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet24$] union all select 日期,制单号,'' as 订单数量,'' as
预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet25$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet26$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet27$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet28$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少
一个参数没有指定值\1.xlsx].[Sheet29$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet3$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet30$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet31$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet32$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组
别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet33$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet34$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet35$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet36$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet37$] union all s
elect 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet38$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet39$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet4$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet40$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from
[Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet41$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet42$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet43$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet44$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet45$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'
' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet46$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet47$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet48$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet49$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没
有指定值\1.xlsx].[Sheet5$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet50$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet51$] union all select 日期,制单号,'' as 订单数量,'' as 预期计划,'' as 收益,工号,姓名,交飞,人事,组别1,组别2,款号,工序号,工序名称,代码,单价,数量,收入 from [Excel 12.0;Database=D:\Desktop\至少一个参数没有指定值\1.xlsx].[Sheet52$]

uceadf

你看你要执行的SQL，这样的语句，你觉得可以执行吗？

uceadf

1. Sub 合并数据() '目的在于合并指定文件夹中的工作簿数据！
   
2.     Dim cnn As Object, rs As Object, rst As Object, d As Object, ds As Object, k
   
3.     Dim SQL$, Mypath$, MyFile$, s$, m&, n&, i%, j&, l&, arrf(), arr(), temp$, strField$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         Mypath = .SelectedItems(1) & ""
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Set ds = CreateObject("scripting.dictionary")
    
12.     Cells.ClearContents
    
13.     MyFile = Dir(Mypath & "*.xls?")
    
14.     Do While MyFile <> ""
    
15.         If MyFile <> ThisWorkbook.Name Then
    
16.             Set cnn = CreateObject("ADODB.Connection")
    
17.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
18.             Set rst = cnn.OpenSchema(20) 'adSchemaTables
    
19.             Do Until rst.EOF
    
20.                 If rst.Fields("TABLE_TYPE") = "TABLE" Then
    
21.                     s = Replace(rst("TABLE_NAME").Value, "'", "")
    
22.                     If s = "Sheet1$" Then GoTo pass:
    
23.                     If Right(s, 1) = "$" Then
    
24.                         Set rs = cnn.Execute("[" & s & "]")
    
25.                         If Left(rs.Fields(0).Name, 1) <> "F" And Not IsNumeric(Mid(rs.Fields(0).Name, 2)) Then
    
26.                             n = n + 1
    
27.                             ReDim Preserve arrf(1 To n)
    
28.                             arrf(n) = "[Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]"
    
29.                             strField = ""
    
30.                             For i = 0 To rs.Fields.Count - 1 '历遍每个工作表的每个字段(判断列数不等的依据)
    
31.                                 temp = rs.Fields(i).Name
    
32.                                 If Left(temp, 1) <> "F" And Not IsNumeric(Mid(temp, 2)) Then '排除其他可能的空字段
    
33.                                     If Not d.Exists(temp) Then d(temp) = "" '字段名写入字典
    
34.                                     strField = strField & temp & "," '字段名用逗号连接
    
35.                                     ds(arrf(n)) = strField & "," '工作簿名与工作表名连接添加到字典ds键值，字段名连接字符串添加到字典条目
    
36.                                 End If
    
37.                             Next
    
38.                         End If
    
39.                     End If
    
40.                 End If
    
41. pass:
    
42.                 rst.MoveNext
    
43.             Loop
    
44.         End If
    
45.         MyFile = Dir()
    
46.     Loop
    
47.     k = d.Keys
    
48.     [a1].Resize(, d.Count) = k
    
49.     For l = 1 To n Step 49
    
50.         m = 0
    
51.         For i = l To l + 48
    
52.             If i > n Then Exit For
    
53.             m = m + 1
    
54.             ReDim Preserve arr(1 To m)
    
55.             For j = 0 To UBound(k) '逐个不重复字段
    
56.                 If InStr(ds(arrf(i)), k(j) & ",") Then '该工作表存在该字段
    
57.                     arr(m) = arr(m) & "," & k(j)
    
58.                 Else
    
59.                     arr(m) = arr(m) & ",'' as " & k(j)  '该工作表不存在该字段要添加 '' as 字段
    
60.                 End If
    
61.             Next
    
62.             arr(m) = "select " & Mid(arr(m), 2) & " from " & arrf(i) & ""
    
63.         Next
    
64.         SQL = Join(arr, " union all ")
    
65.         Erase arr
    
66.         Range("a" & Range("A1").CurrentRegion.Rows.Count + 1).CopyFromRecordset cnn.Execute(SQL)
    
67.     Next
    
68.     rs.Close
    
69.     rst.Close
    
70.     cnn.Close
    
71.     Set rs = Nothing
    
72.     Set rst = Nothing
    
73.     Set cnn = Nothing
    
74.     Application.ScreenUpdating = True
    
75. End Sub

复制代码

uceadf

不能运行是因为你Sheet1里面的字段不同，无法使用UNION ALL命令连接其它的表

把Sheet1 psss就好了

张雄友

代码完全一样的怎么不行？1点多起来看了一小时没看出来哪里不同。

Sub 合并数据不行()
    Dim cnn As Object, rs As Object, rst As Object, d As Object, ds As Object, k
    Dim SQL$, Mypath$, MyFile$, s$, m&, n&, i%, j&, l&, arrf(), arr(), temp$, strField$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        Mypath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    Cells.ClearContents
    MyFile = Dir(Mypath & "*.xls")
    Do While MyFile <> ""
       If MyFile <> ThisWorkbook.Name Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
            Set rst = cnn.OpenSchema(20) 'adSchemaTables
            Do Until rst.EOF
                If rst.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rst("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        Set rs = cnn.Execute("[" & s & "]")
                        If Left(rs.Fields(0).Name, 1) <> "F" And Not IsNumeric(Mid(rs.Fields(0).Name, 2)) Then
                            n = n + 1
                            ReDim Preserve arrf(1 To n)
                            arrf(n) = "[Excel 12.0;Database=" & Mypath & MyFile & "].[" & s & "]"
                            strField = ""
                            For i = 0 To rs.Fields.Count - 1 '历遍每个工作表的每个字段(判断列数不等的依据)
                                temp = rs.Fields(i).Name
                                If Left(temp, 1) <> "F" And Not IsNumeric(Mid(temp, 2)) Then '排除其他可能的空字段
                                If Len(temp) Then
                                    If Not d.Exists(temp) Then d(temp) = "" '字段名写入字典
                                    End If
                                    strField = strField & temp & "," '字段名用逗号连接
                                    ds(arrf(n)) = strField & "," '工作簿名与工作表名连接添加到字典ds键值，字段名连接字符串添加到字典条目
                                End If
                            Next
                        End If
                    End If
                End If
                rst.MoveNext
            Loop
        End If
        MyFile = Dir()
    Loop
    k = d.Keys
    [a1].Resize(, d.Count) = k
    For l = 1 To n Step 49
        m = 0
        For i = l To l + 48
            If i > n Then Exit For
            m = m + 1
            ReDim Preserve arr(1 To m)
            For j = 0 To UBound(k) '逐个不重复字段
                If InStr(ds(arrf(i)), k(j) & ",") Then '该工作表存在该字段
                    arr(m) = arr(m) & "," & k(j)
                Else
                    arr(m) = arr(m) & ",'' as " & k(j)  '该工作表不存在该字段要添加 '' as 字段
                End If
            Next
            arr(m) = "select " & Mid(arr(m), 2) & " from " & arrf(i) & ""
        Next
        SQL = Join(arr, " union all ")
        Erase arr
        Range("a" & Range("A1").CurrentRegion.Rows.Count + 1).CopyFromRecordset cnn.Execute(SQL)
    Next
    rs.Close
    rst.Close
    cnn.Close
    Set rs = Nothing
    Set rst = Nothing
    Set cnn = Nothing
    Application.ScreenUpdating = True
End Sub

hwc2ycy

你的代码里判断字段名的方法有BUG，应该前后都要加，分界符。

张雄友

hwc2ycy 发表于 2014-11-17 09:31
你的代码里判断字段名的方法有BUG，应该前后都要加，分界符。

If InStr("," & ds(arrf(i)), "," & k(j) & ",") Then '该工作表存在该字段，你的代码里判断字段名的方法有BUG，应该前后都要加，分界符。



这句？

张雄友

hwc2ycy 发表于 2014-11-16 21:51

在前面增加二列，列出它们是来自哪个工作簿的，那个工作表的，怎么加？