Sub Mail_ActiveSheet()'Working in 2

Sub Mail_ActiveSheet()'Working in 2000-2007 Dim FileExtStr As String, TempFilePath As String, TempFileName As String Dim MTO As String, MCC As String, Ad As String, Sql As String Dim Addr As Integer Dim FileFormatNum As Long Dim Sourcewb As Workbook, Destwb As Workbook Dim OutApp As Object, OutMail As Object, Conn As Object With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False End With With Sheet2 For i = 1 To .[A65536].End(xlUp).Row Set c = Sheet1.Range("A1:A" & Sheet1.[A65536].End(xlUp).Row).Find(.Cells(i, 1), , , 1) If Not c Is Nothing Then For Each sh In Sheets If sh.Index > 2 Then sh.Delete '刪除"明细"工作表 Next sh Sheets.Add After:=Sheets(Sheets.Count) '新增筛选工作表 ActiveSheet.Name = .Cells(i, 1) '新工作表命名 Sheet1.Rows("1:1").Copy ActiveSheet.Cells(1, 1) '复制表头 Addr = Sheet1.[a1].End(xlToRight).Column Ad = Split(Cells(1, Addr).Address, "$")(1) Set Conn = CreateObject("adodb.connection") If Val(Application.Version) < 12 Then 'You use Excel 2000-2003 FileExtStr = ".xls": FileFormatNum = -4143 Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';Data Source=" & ThisWorkbook.FullName Else 'You use Excel 2007-2010 FileExtStr = ".xlsx": FileFormatNum = 51 Conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName End If Sql = "select * from [明细$A2:i" & Ad & Sheet1.[A65536].End(xlUp).Row & "] where f1='" & .Cells(i, 1) & "'" ActiveSheet.Cells(2, 1).CopyFromRecordset Conn.Execute(Sql) '筛选数据到新增工作表 Conn.Close Set Conn = Nothing ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous '画表格线