20170112xlVBA查询SQL

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164

Sub NextSeven_CodeFrame() '应用程序设置     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 Rng As Range     Dim Arr As Variant     Dim EndRow As Long       Dim oSht As Worksheet     Dim DataPath As String     Dim SQL As String     Dim EndDate As Date     Dim StartDate As Date     Dim Client As String           '实例化对象     Set wb = Application.ThisWorkbook     Set sht = wb.Worksheets("凭证录入")     Set oSht = wb.Worksheets("客户明细")     DataPath = wb.FullName           usertxt = Application.InputBox("请输入开始日期", "开始日期", , , , , , 2)     If usertxt = False Then Exit Sub     StartDate = Format(CDate(usertxt), "yyyy-mm-dd")         usertxt = Application.InputBox("请输入结束日期", "结束日期", , , , , , 2)     If usertxt = False Then Exit Sub     EndDate = Format(CDate(usertxt), "yyyy-mm-dd")       usertxt = Application.InputBox("请输入客户姓名", "客户姓名", , , , , , 2)     If usertxt = False Then Exit Sub     Client = CStr(usertxt)         oSht.UsedRange.Offset(1).Clear     Set Rng = oSht.Range("A2")       SQL = "SELECT * FROM [" & sht.Name & "$A3:V] WHERE  出货客户='" & Client & "' AND ( 出货日期 Between  #" & StartDate & "# AND #" & EndDate & "#  )"     SQL = SQL & " ORDER BY 型号 ASC"     If RecordExistsRunSQL(DataPath, SQL) = True Then         GetRecordSetIntoRange DataPath, SQL, Rng     End If           '运行耗时     UsedTime = VBA.Timer - StartTime     MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒") ErrorExit:        '错误处理结束，开始环境清理     Set wb = Nothing     Set sht = Nothing     Set Rng = 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   Public Sub GetRecordSetIntoRange(ByVal DataPath As String, ByVal SQL As String, ByVal Rng As Range) '对传入数据源地址进行判断     If Len(DataPath) = 0 Or Len(Dir(DataPath)) = 0 Then _  MsgBox "数据源地址为空或者数据源文件不存在！", vbInformation, "NS Excel Studio": Exit Sub     '对传入SQL语句进行判断     If Len(SQL) = 0 Then _  MsgBox "SQL语句不能为空！", vbInformation, "NS Excel Studio": Exit Sub     '对象变量声明     Dim cnn As Object     Dim rs As Object     '数据库引擎——Excel作为数据源     Const DATA_ENGINE As String = "Provider=Microsoft.jet.OLEDB.4.0;" & _           "Extended Properties='Excel 8.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     '执行查询 返回记录集     rs.Open SQL, cnn, 1, 1     'Set RS = CNN.Execute(SQL)     '复制记录集到指定Range     Rng.CopyFromRecordset rs     '关闭记录集     rs.Close     '关闭连接器     cnn.Close     '释放对象     Set rs = Nothing     Set cnn = Nothing End Sub Public Function RecordExistsRunSQL(ByVal DataPath As String, ByVal SQL As String) As Boolean '对传入数据源地址进行判断     If Len(DataPath) = 0 Or Len(Dir(DataPath)) = 0 Then         RecordExistsRunSQL = False         MsgBox "数据源地址为空或者数据源文件不存在！", vbInformation, "NS Excel Studio"         Exit Function     End If     '对传入SQL语句进行判断     If Len(SQL) = 0 Then         RecordExistsRunSQL = False         MsgBox "SQL语句不能为空！", vbInformation, "NS Excel Studio"         Exit Function     End If     '对象变量声明     Dim cnn As Object     Dim rs As Object     '数据库引擎——Excel作为数据源     'Const DATA_ENGINE As String = "Provider=Microsoft.ACE.OLEDB.12.0;" & _          ' "Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "                          '数据库引擎——Excel作为数据源     Const DATA_ENGINE As String = "Provider=Microsoft.jet.OLEDB.4.0;" & _           "Extended Properties='Excel 8.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     '执行查询 返回记录集     rs.Open SQL, cnn, 1, 1     '返回函数结果     If rs.RecordCount > 0 Then         RecordExistsRunSQL = True     Else         RecordExistsRunSQL = False     End If     '关闭记录集     rs.Close     '关闭连接器     cnn.Close     '释放对象     Set rs = Nothing     Set cnn = Nothing End Function