2017-09-21xlVBA_蒸發SQL循環查詢1
阿新 • • 發佈:2017-09-22
per sele sql debug 實例化 mex from 查詢 計時器
‘ARRAY("1991","1992","1993","1994","1996","1997","1998","1999","2001") Sub ADO_SQL_QUERY_ONE_RNG() ‘應用程序設置 Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual ‘錯誤處理 On Error GoTo ErrHandler ‘計時器 Dim StartTime, UsedTime As Variant StartTime = VBA.Timer ‘變量聲明 Dim Wb As Workbook Dim Sht As Worksheet Dim DataSht As Worksheet Dim Rng As Range Dim Arr As Variant Dim EndRow As Long Dim DataPath As String Dim SQL As String ‘實例化對象 Set Wb = Application.ThisWorkbook DataPath = Wb.Path & "\" & "蒸發214.xlsx" ‘Wb.FullName ‘Set DataSht = Wb.Worksheets("2001") ‘Set Sht = Wb.Worksheets("result") ‘******************************************************************************************************************** ‘對象變量聲明 Dim CNN As Object Dim RS As Object ‘數據庫引擎——Excel作為數據源 Dim DATA_ENGINE As String ‘Select Case Application.Version * 1 ‘設置連接字符串,根據版本創建連接 ‘Case Is <= 11 ‘ DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=‘Excel 8.0;HDR=YES;IMEX=2‘;Data Source=" ‘Case Is >= 12 DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=‘Excel 12.0;HDR=YES;IMEX=2‘; Data Source= " ‘End Select ‘數據庫引擎——Excel作為數據源 ‘Const DATA_ENGINE As String = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Extended Properties=‘Excel 12.0;HDR=YES;IMEX=2‘; Data Source= " ‘創建ADO Connection 連接器 實例 Set CNN = CreateObject("ADODB.Connection") ‘On Error Resume Next ‘創建 ADO RecordSet 記錄集 實例 Set RS = CreateObject("ADODB.RecordSet") ‘連接數據源 CNN.Open DATA_ENGINE & DataPath ‘******************************************************************************************************************** ‘dataname = Array("1991", "1992", "1993", "1994", "1996", "1997", "1998", "1999", "2001") dataname = Array("2002", "2003", "2004", "2006", "2007", "2008", "2009", "2011", "2012", "2013", "2014") For i = LBound(dataname) To UBound(dataname) On Error Resume Next Wb.Worksheets(dataname(i) & "坐標").Delete On Error GoTo 0 Set Sht = Wb.Worksheets.Add(after:=Wb.Worksheets(Wb.Worksheets.Count)) Sht.Name = dataname(i) & "坐標" With Sht EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row .Cells.ClearContents .Range("A1:F1").Value = Array("站點", "經度", "緯度", "年", "數據", "數據除10") Set Rng = .Range("A2") ‘設置查詢語句 SQL = "SELECT 站點,經度,緯度,年,SUM(值),SUM(值)/10 FROM [" & dataname(i) & "$A1:G] WHERE 站點 IS NOT NULL GROUP BY 站點,經度,緯度,年" Debug.Print SQL ‘執行查詢 返回記錄集 ‘RS.Open SQL, CNN, 1, 1 Set RS = CNN.Execute(SQL) ‘復制記錄集到指定Range Rng.CopyFromRecordset RS End With Next i ‘關閉記錄集 RS.Close ‘關閉連接器 CNN.Close ‘運行耗時 UsedTime = VBA.Timer - StartTime ErrorExit: ‘錯誤處理結束,開始環境清理 Set Wb = Nothing Set Sht = Nothing Set Rng = Nothing ‘釋放對象 Set RS = Nothing Set CNN = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description & "!", vbCritical, "錯誤提示!" ‘Debug.Print Err.Description Err.Clear ‘Resume ErrorExit End If End Sub
2017-09-21xlVBA_蒸發SQL循環查詢1