2017-09-21xlVBA_蒸发SQL循环查询1

'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