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
