2017-09-21xlvba_ evaporation SQL Circular Query 1

' ARRAY ("1991", "1992", "1993", "1994", "1996", "1997", "1998", "1999", "2001") Sub Ado_sql_query_one_rng () ' Application settings    Application.ScreenUpdating = False Application.DisplayAlerts = False Application.calculation = Xlcalculationmanual ' Error handling On Error GoTo ErrHandler ' timer Dim StartTime, usedtime as Variant StartTime = VBA.  Timer ' variable declaration 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 ' instantiation object Set Wb = Application.thisworkbo  Ok DataPath = wb.path & "\" & "evaporation 214.xlsx" ' wb.fullname ' Set Datasht = Wb.worksheets ("2001") ' Set Sht = wb.worksheets ("result") ' ********************************************************************************** ' Object variable declaration Dim CNN As Object Dim RS As Object ' database engine--excel as data source Dim data_e Ngine as String ' Select case application.version * 1 ' Set connectionString, create a connection according to the version ' case is <= one ' data_engine = ' provider=microsoft.jet.oledb.4.0; Extended properties= ' Excel 8.0; hdr=yes;imex=2 ';D ata source= "' Case is >=-data_engine = ' provider=microsoft.ace.oledb.12.0; Extended properties= ' Excel 12.0; Hdr=yes;imex=2 ';  Data source= "' End select ' Database Engine--excel as the DataSource ' Const data_engine as String =" provider=microsoft.ace.oledb.12.0; " & _ "Extended properties= ' Excel 12.0; Hdr=yes;imex=2 '; Data source= "' Creates an ADO Connection connector instance Set CNN = CreateObject (" ADODB. Connection ") ' on Error Resume Next ' creates an ADO recordset Recordset instance Set RS = CreateObject (" ADODB. RecordSet ") ' Connected data source 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 "," (")," "," ") For i = LBound (dataname) to UBound (dataname) on Error Resume Next Wb.worksheets (d Ataname (i) & "coordinates"). Delete on Error GoTo 0 Set Sht = Wb.Worksheets.Add (After:=wb.worksheets (Wb.Worksheets.Count)) Sht.name = data Name (i) & "coordinates" with Sht Endrow =. Cells (. Cells.Rows.Count, 2). End (Xlup). Row. Cells.clearcontents. Range ("A1:f1"). Value = Array ("Site", "longitude", "latitude", "year", "Data", "Data Apart") Set Rng =. Range ("A2") ' Set query statement SQL = ' Select site, longitude, latitude, year, sum (value), sum (value)/10 from ["& Dataname (i) &" $A 1:g] WHERE Site is not a NULL GROUP by site, longitude, latitude, year "Debug.Print SQL" executes the query return Recordset ' RS. Open SQL, CNN, 1, 1 Set RS = CNN. Execute (SQL) ' copies the recordset to the specified range Rng.copyfromrecordset Rs End with Next i ' Close the recordset Rs. Close ' off the connector CNN. Close ' run time Usedtime = VBA. Timer-starttimeerrorexit: ' Error handling ended, start environment cleanup Set Wb = Nothing Set Sht = Nothing Set Rng = Nothing ' Release object Set RS = Nothing Set CNN = Nothing application.screenupdating = True APPLICATION.DISPL Ayalerts = True application.calculation = xlcalculationautomatic Exit suberrhandler:if err.number <> 0 The N MsgBox err.description & "! ", vbcritical," Error prompt! "' Debug.Print err.description err.clear ' Resume errorexit End ifend Sub

　　

2017-09-21xlvba_ evaporation SQL Circular Query 1