'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
