20170112xlVBA查询SQL

Posted 2020-09-27 Excel VBA 小天地

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