‘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