2019獨角獸企業重金招聘Python工程師標準>>>

以下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'查找現有WORKBOOK，如果已經有匯總表-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讀入標題欄 TitleArr = Sheet1.Range("A1").Resize(1, MaxClm) '循環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 & ") " '執行QUERY .Range("A2").CopyFromRecordset Conn.Execute(SQL) '讀入標題欄 .Cells(1, 1) = "WorkSheet" .Range("B1").Resize(1, UBound(TitleArr, 2)) = TitleArr'釋放內存 Conn.Close: Set Conn = Nothing 'UpdateScreen Application.ScreenUpdating = True End With End Sub

?

?

?

轉載于:https://my.oschina.net/tedzheng/blog/658365

總結

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

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。