- 积分
- 140
- 贡献
-
- 精华
- 在线时间
- 小时
- 注册时间
- 2012-7-5
- 最后登录
- 1970-1-1
|
发表于 2015-2-6 20:47:04
|
显示全部楼层
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim conn As Object, SQL$, Myfile$, Mypath$
Dim Arr, n&, wbname$
Myfile = ThisWorkbook.FullName
Mypath = ThisWorkbook.Path & "\"
SQL = "Select Distinct f1 from [Sheet1$A1:A] Where f1 is not null"
Set conn = CreateObject("ADODB.Connection")
If Application.Version = "11.0" Then
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties= 'Excel 12.0; hdr=no'; Data Source=" & Myfile
Else
conn.Open "Provider=Microsoft.JET.OLEDB.4.0; Extended Properties= 'Excel 8.0; hdr=no'; Data Source=" & Myfile
End If
Sheets(2).[a1].CopyFromRecordset conn.Execute(SQL)
Arr = Sheets(2).[a1].CurrentRegion
Sheets.Add after:=Sheets(3), Count:=UBound(Arr)
For n = UBound(Arr) To 1 Step -1
wbname = Arr(n, 1)
SQL = "Select f1,f7,f12,f14 from [Sheet1$A2:N] Where f1=" & Arr(n, 1)
Sheets(n + 3).[A1:D1] = Array("站号", "平均气温", "最低气温", "最高气温")
Sheets(n + 3).[a2].CopyFromRecordset conn.Execute(SQL)
Sheets(Sheets.Count).Move
ActiveWorkbook.SaveAs Filename:=Mypath & wbname & ".xls"
ActiveWorkbook.Close
Next
conn.Close
Set conn = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub |
|