|
|
Office2007及以上版本不支持FileSearch对象，根据原程序，使用Fso代替比Dir函数要好：
Public Sub 汇总()
Dim myPath As String, DefaultPath As String, mysql As String
Dim i As Integer, j As Integer, n As Integer, p As Integer
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim Fso As Object, oFile As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
'删除当前工作簿的"原始数据汇总"工作簿的所有数据
Worksheets("原始数据汇总").Cells.Clear
'开始从指定的文件夹中寻找要汇总工作簿文件
DefaultPath = ThisWorkbook.Path & "\初一年级\"
myPath = InputBox("请输入要查询工作簿的文件夹完整目录及名字：" _
& vbCrLf & vbCrLf & "如果为空，则默认为" & vbCrLf _
& DefaultPath, "输入路径", DefaultPath)
If myPath = "" Then myPath = DefaultPath
Application.StatusBar = "正在查找汇总工作簿......"
p = Fso.GetFolder(myPath).Files.Count
If p > 0 Then
MsgBox "在此文件夹中共有 " & p & " 个工作表的数据文件需要汇总！", _
vbInformation, "搜索到汇总文件"
ReDim myfile(1 To p) As String
For Each oFile In Fso.GetFolder(myPath).Files
i = i + 1
myfile(i) = oFile
Next
' For i = 1 To p
' myfile(i) = .FoundFiles(i)
' Next i
Else
MsgBox "没有搜索到要汇总的文件！", vbInformation, "没有汇总文件"
Application.StatusBar = False
Exit Sub
End If
' Set fs = Application.FileSearch
' With fs
' .LookIn = myPath
' .FileType = msoFileTypeExcelWorkbooks
' If .Execute(SortBy:=msoSortByFileName, _
' SortOrder:=msoSortOrderAscending) > 0 Then
' p = .FoundFiles.Count
' MsgBox "在此文件夹中共有 " & p & " 个工作表的数据文件需要汇总！", _
' vbInformation, "搜索到汇总文件"
' ReDim myfile(p) As String
' For i = 1 To p
' myfile(i) = .FoundFiles(i)
' Next i
' Else
' MsgBox "没有搜索到要汇总的文件！", vbInformation, "没有汇总文件"
' Application.StatusBar = False
' Exit Sub
' End If
' End With
'建立与每个工作簿的连接，查询全部数据记录,并复制到当前工作表"原始数据汇总"中
For i = 1 To p
'建立与每个作簿的连接
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.ConnectionString = "Extended Properties=Excel 8.0;" _
& "Data Source=" & myfile(i)
.Open
End With
'查询每个工作簿的全部记录数据
Set rs = New ADODB.Recordset
mysql = "select * from [Sheet1$]"
rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
If i = 1 Then '复制字段名称到"原始数据汇总"工作表
For j = 0 To rs.Fields.Count - 1
Worksheets("原始数据汇总").Cells(1, j + 1) = rs.Fields(j).Name
Next j
End If
'获取当前工作簿的"原始数据汇总"工作表的最后一行数据
n = Worksheets("原始数据汇总").Range("A65536").End(xlUp).Row
If rs.RecordCount <> 0 Then
'将查询到的学生记录复制到"汇总"工作表
Worksheets("原始数据汇总").Range("A" & n + 1).CopyFromRecordset rs
End If
Next i
Application.StatusBar = False
MsgBox "工作簿汇总完毕！共汇总了 " & p & " 个工作簿。", vbInformation, "汇总完毕"
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub
|
评分
-
2
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2016-4-15 08:48
楼主
发表于 2016-11-16 20:19
