偶看新闻紫日是真的吗:分工作表汇总成一表问题
来源：百度文库 编辑：偶看新闻 时间：2024/04/28 16:50:58
Sub pldrwb1203()
'汇总.xls
Dim myFs As FileSearch, Sht1 As Worksheet, Sht As Worksheet
Dim myPath As String, Filename$
Dim i As Long, n As Long,aa,nm$,na%
Dim conn As Object, yy As Object, sql As String
Set Sht1 = ActiveSheet
Sht1.[a2:c1000] = ""
Set conn = CreateObject("Adodb.Connection")
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName) > 0 Then
n = .FoundFiles.Count
ReDim myfile(1 To n) As String
For i = 1 To n
myfile(i) = .FoundFiles(i)
Filename = myfile(i)
aa = InStrRev(Filename, "\")
nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名
If nm = ThisWorkbook.Name Then GoTo 100
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0';data source=" & Filename
sql = "select A.单位名称,B.单位人员数量,C.单位领导数量 from [表一$] as A,[表二$] as B,[表三$] as C"
na = Sht1.[a65536].End(xlUp).Row + 1
Sht1.Cells(na, 1).CopyFromRecordset conn.Execute(sql)
conn.Close
100: Next i
Set conn = Nothing
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
[a1].Select
Set myFs = Nothing
End Sub
'汇总.xls
Dim myFs As FileSearch, Sht1 As Worksheet, Sht As Worksheet
Dim myPath As String, Filename$
Dim i As Long, n As Long,aa,nm$,na%
Dim conn As Object, yy As Object, sql As String
Set Sht1 = ActiveSheet
Sht1.[a2:c1000] = ""
Set conn = CreateObject("Adodb.Connection")
Set myFs = Application.FileSearch
myPath = ThisWorkbook.Path
With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypeNoteItem
.Filename = "*.xls"
If .Execute(SortBy:=msoSortByFileName) > 0 Then
n = .FoundFiles.Count
ReDim myfile(1 To n) As String
For i = 1 To n
myfile(i) = .FoundFiles(i)
Filename = myfile(i)
aa = InStrRev(Filename, "\")
nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名
If nm = ThisWorkbook.Name Then GoTo 100
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0';data source=" & Filename
sql = "select A.单位名称,B.单位人员数量,C.单位领导数量 from [表一$] as A,[表二$] as B,[表三$] as C"
na = Sht1.[a65536].End(xlUp).Row + 1
Sht1.Cells(na, 1).CopyFromRecordset conn.Execute(sql)
conn.Close
100: Next i
Set conn = Nothing
Else
MsgBox "该文件夹里没有任何文件"
End If
End With
[a1].Select
Set myFs = Nothing
End Sub