|
|
楼主 |
发表于 2015-4-3 19:20
|
显示全部楼层
本帖最后由 张雄友 于 2015-4-3 19:28 编辑
附上03版附件。
Sub ADO提取工号姓名实发工资整列()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rst As ADODB.Recordset
Dim SQL As String
Dim i As Long
Dim r As Long
Dim m As Long
Dim arr() As String
Dim a As Variant
Dim s As String
Dim Temp As String
Dim MyPath As String
Dim MyName As String
Dim shName As String
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
Filepath = GetName(MyPath)
For x = 0 To UBound(Filepath)
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Filepath(x)
Application.ScreenUpdating = False
a = Array("工号", "姓名", "实发工资")
ActiveSheet.UsedRange.Offset(1).ClearContents
Set rst = cnn.OpenSchema(adSchemaTables)
Do Until rst.EOF
If rst.Fields("TABLE_TYPE") = "TABLE" Then
shName = Replace(rst("TABLE_NAME").Value, "'", "")
If Right(shName, 1) = "$" Then
Set rs = cnn.Execute("select * from [" & shName & "]")
s = rs.Fields(1).Name
If Err.Number = 0 Then
Temp = "|" & rs.Fields(1).Name
For i = 2 To rs.Fields.Count - 1
Temp = Temp & "|" & rs.Fields(i).Name
Next
Temp = Temp & "|"
m = m + 1
If m > 49 Then
r = Range("A1").CurrentRegion.Rows.Count + 1
Range("A" & r).CopyFromRecordset cnn.Execute(Join(arr, " UNION ALL "))
m = 1
Erase arr
End If
ReDim Preserve arr(1 To m)
s = ""
For i = 0 To 2
If InStr(Temp, "|" & a(i) & "|") Then
s = s & "," & a(i)
Else
s = s & ",null as " & a(i)
End If
Next
arr(m) = "select '" & Filepath(x) & "' as 工作簿名,'" & Replace(shName, "$", "") & "' as 工作表名" & s & " from [Excel 12.0;Database=" & Filepath(x) & ";].[" & shName & "] where 工号 is not null"
Else
Err.Clear
End If
End If
End If
rst.MoveNext
Loop
Next
SQL = Join(arr, " UNION ALL ")
r = Range("A1").CurrentRegion.Rows.Count + 1
Range("A" & r).CopyFromRecordset cnn.Execute(SQL)
rs.Close
rst.Close
cnn.Close
Set rs = Nothing
Set rst = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox "OK!"
End Sub
Function GetName(lj As String) '遍历所有EXCEL文件
Dim MyName, dic, Did, i, t, F, tt, MyFileName
Set dic = CreateObject("Scripting.Dictionary")
Set Did = CreateObject("Scripting.Dictionary")
dic.Add (lj), ""
i = 0
Do While i < dic.Count
Ke = dic.Keys
MyName = Dir(Ke(i), vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
dic.Add (Ke(i) & MyName & "\"), ""
End If
End If
MyName = Dir
Loop
i = i + 1
Loop
For Each Ke In dic.Keys
MyFileName = Dir(Ke & "*.xls*")
Do While MyFileName <> ""
If MyFileName <> ThisWorkbook.Name Then Did.Add (Ke & MyFileName), ""
MyFileName = Dir
Loop
Next
GetName = Did.Keys
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-4-3 07:11
