'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,NULL FROM [" & dataname(i) & "$A1:G] WHERE 站点  IS NOT NULL GROUP BY 年,月,日"

        '执行查询 返回记录集

        '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

Sub GetDateIndex()

    For Each Sht In ThisWorkbook.Worksheets

        If Sht.Name Like "*日子" Then

            lastYear = CLng(Left(Sht.Name, 4)) - 1

            startdate = CDate(lastYear & "/12/31")

            Debug.Print startdate

            With Sht

                EndRow = .Range("A65536").End(xlUp).Row

                For i = 2 To EndRow

                    today = CDate(.Cells(i, 1).Value & "/" & .Cells(i, 2).Value & "/" & .Cells(i, 3).Value)

                    .Cells(i, 6).Value = DateDiff("d", startdate, today)

                Next i

            End With

        End If

    Next Sht

End Sub