20170923xlVBA_UpdateClientDetailSQL_Dictionary

Posted 2020-10-08 Excel VBA 小天地

Sub UpdateClientDetailWGQ()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim Brr As Variant
    Dim dData As Object
    Dim dRow As Object
    Dim Key As String
    Dim OneKey
    
    Set dData = CreateObject("Scripting.Dictionary")
    Set dRow = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    
    ‘Set Sht = Wb.Worksheets("CPU")
    
    ‘选择文件
    Dim FilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        .Title = "请选择单个Excel工作簿"
        .Filters.Clear
        .Filters.Add "Excel工作簿", "*.xls*"
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With
    ‘查询更新内容
    For Each Sht In Wb.Worksheets
        
        SQL = "SELECT F2,F9,F10,F11,F12,F13,F14,F15 FROM [" & Sht.Name & "$A2:O] WHERE F9 IS NOT NULL"
        Debug.Print SQL
        If RecordExistsRunSQL(FilePath, SQL) Then
            
            Arr = RunSQLReturnArray(FilePath, SQL)
            For j = LBound(Arr, 2) To UBound(Arr, 2)
                Key = CStr(Arr(0, j))
                ‘For i = LBound(Arr) To UBound(Arr)
                ‘Debug.Print Key
                dData(Key) = Array(Arr(1, j), Arr(2, j), Arr(3, j), Arr(4, j), Arr(5, j), Arr(6, j), Arr(7, j))
                ‘Next i
            Next j
            
            With Sht
                endrow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
                Set Rng = .Range("A2:O" & endrow)
                Brr = Rng.Value
                For i = LBound(Brr) To UBound(Brr)
                    Key = CStr(Brr(i, 2))
                    ‘Debug.Print Key
                    dRow(Key) = i
                Next i
                
                For Each OneKey In dData.keys
                    If dRow.exists(OneKey) Then
                        ar = dData(OneKey)
                        For j = LBound(ar) To UBound(ar)
                            Brr(dRow(OneKey), j + 9) = ar(j)
                        Next j
                    End If
                Next OneKey
                Rng.Value = Brr
            End With
        End If
    Next Sht
    
    Set Wb = Nothing
    Set dData = Nothing
    Set dRow = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    
End Sub
Public Function RunSQLReturnArray(ByVal DataPath As String, ByVal SQL As String) As Variant()
‘对传入数据源地址进行判断
    If Len(DataPath) = 0 Or Len(Dir(DataPath)) = 0 Then
        MsgBox "数据源地址为空或者数据源文件不存在！", vbInformation, "NS Excel Studio"
        Exit Function
    End If
    ‘对传入SQL语句进行判断
    If Len(SQL) = 0 Then _
 MsgBox "SQL语句不能为空！", vbInformation, "NS Excel Studio": Exit Function
    ‘对象变量声明
    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=no;IMEX=2‘;Data Source="
    Case Is >= 12
        DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=‘Excel 12.0;HDR=no;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
    ‘执行查询 返回记录集
    ‘ RS.Open SQL, CNN, 1, 1
    Set RS = CNN.Execute(SQL)
    RunSQLReturnArray = RS.GetRows()
    ‘关闭记录集
    ‘RS.Close
    ‘关闭连接器
    CNN.Close
    ‘释放对象
    Set RS = Nothing
    Set CNN = Nothing
End Function

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作为数据源
    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=no;IMEX=2‘;Data Source="
    Case Is >= 12
        DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=‘Excel 12.0;HDR=no;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
    ‘执行查询 返回记录集
    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