|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub DoCnn()
Dim cnn As Object, rst As Object, Cnn_str$, d As Object
Dim rs As Object
x = Val([c1]): y = Val([c2])
If x = 0 Or y = 0 Then MsgBox "未输入查询月份": Exit Sub
Set cnn = CreateObject("adodb.connection")
Set d = CreateObject("scripting.dictionary")
Cnn_str = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source="
tr = Range("b5").Resize(1, Cells(5, Columns.Count).End(1).Column - 1)
For i = 1 To UBound(tr, 2)
If Len(tr(1, i)) = 0 Then MsgBox "标题字段中存在空白，重新设置。": Exit Sub
Next
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
cnn.Open Cnn_str & p & f
d.RemoveAll
Set rst = cnn.openschema(20)
Do Until rst.EOF
shtn = Replace(rst.Fields("TABLE_NAME"), "'", "")
If Right(shtn, 1) = "$" Then
shtv = Val(shtn)
If shtv >= x And shtv <= y Then
Set d(shtn) = CreateObject("scripting.dictionary")
Set rs = cnn.Execute("select * from [" & shtn & "a5:az5]")
For n = 0 To rs.Fields.Count - 1
d(shtn)(rs.Fields(n).Name) = ""
Next
End If
End If
rst.movenext
Loop
kr = d.keys '表名
wkn = Split(f, ".xls")(0)
For i = 0 To UBound(kr)
shtn = kr(i)
sl = sl & "select '" & wkn & "' as 工作簿名,"
For j = 1 To UBound(tr, 2)
If d(shtn).exists(tr(1, j)) Then
sl = sl & "[" & tr(1, j) & "],"
Else
sl = sl & " null as " & tr(1, j) & ","
End If
Next
sl = Left(sl, Len(sl) - 1) & " from [excel 12.0;database=" & p & f & "].[" & shtn & "a5:az] union all "
Next
cnn.Close
End If
f = Dir
Loop
ActiveSheet.UsedRange.Offset(5).ClearContents
cnn.Open Cnn_str & ThisWorkbook.FullName
Range("a6").CopyFromRecordset cnn.Execute(Left(sl, Len(sl) - 10))
cnn.Close
Set cnn = Nothing
Range("a5").Resize(Cells(Rows.Count, 1).End(3).Row - 4, UBound(tr, 2) + 1).Sort [a5], xlAscending, Header:=xlYes
MsgBox "ok"
End Sub
|
评分
-
2
查看全部评分
-
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-4-23 21:27
发表于 2018-4-24 06:45
楼主
