2019獨(dú)角獸企業(yè)重金招聘Python工程師標(biāo)準(zhǔn)>>>

以下VBA用以匯總相同格式的工作表.

Option Explicit Sub Collection() 'Collection Data into TTL worksheet Dim Sh As Worksheet, SQL$, m%, Conn As Object Dim MaxClm&, TitleArr() '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Set Conn = CreateObject("adodb.connection") Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;imex=1';data source=" & ActiveWorkbook.FullName Application.ScreenUpdating = False 'Unable Screen Update Application.DisplayAlerts = False 'No Alert for TTL sheet delete For Each Sh In Sheets'查找現(xiàn)有WORKBOOK，如果已經(jīng)有匯總表-TTL,刪除If Sh.Name = "TTL" Then Sheets("TTL").Delete Next '增加新的匯總表-TTL Set Sh = Sheets.Add(After:=Sheets(Sheets.Count)) Sh.Name = "TTL" Application.DisplayAlerts = True 'Alert enableWith Sheets("TTL") .UsedRange.ClearContents 'Clear data MaxClm = Sheet1.[AX1].End(xlToLeft).Column 'Last column '從SHEET1讀入標(biāo)題欄 TitleArr = Sheet1.Range("A1").Resize(1, MaxClm) '循環(huán)SHEET For Each Sh In SheetsIf Sh.Name <> "TTL" Thenm = m + 1If m = 1 ThenSQL = "select '" & Sh.Name & "',* from [" & Sh.Name & "$A:J]"ElseSQL = SQL & " union all select '" & Sh.Name & "',* from [" & Sh.Name & "$A:J]"End IfEnd If Next SQL = "select * from (" & SQL & ") " '執(zhí)行QUERY .Range("A2").CopyFromRecordset Conn.Execute(SQL) '讀入標(biāo)題欄 .Cells(1, 1) = "WorkSheet" .Range("B1").Resize(1, UBound(TitleArr, 2)) = TitleArr'釋放內(nèi)存 Conn.Close: Set Conn = Nothing 'UpdateScreen Application.ScreenUpdating = True End With End Sub

?

?

?

轉(zhuǎn)載于:https://my.oschina.net/tedzheng/blog/658365

總結(jié)

以上是生活随笔為你收集整理的相同格式EXCEL汇总的全部?jī)?nèi)容，希望文章能夠幫你解決所遇到的問(wèn)題。

如果覺(jué)得生活随笔網(wǎng)站內(nèi)容還不錯(cuò)，歡迎將生活随笔推薦給好友。