|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub test22()
Sheet2.Activate
Application.ScreenUpdating = False
Dim ar, Dict As Object, s As String, i As Long, j As Long
Set Dict = CreateObject("Scripting.Dictionary")
ar = Sheet2.Range("A2:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(ar)
s = Split(ar(i, 1), ".")(0)
If Len(s) Then Dict(s) = i
Next
Dim Cn As Object, Rs As Object, Sq As String
Set Cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
Cn.Open "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
s = "Excel 8.0;HDR=yes;Database="
Else
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
s = "Excel 12.0;HDR=yes;Database="
End If
Dim p As String, f, br, x As Long, y As Long
p = ThisWorkbook.Path & "\"
f = Array("data1.xls", "data2.xls")
For x = 0 To UBound(f)
If Len(Dir(p & f(x))) Then
For i = 1 To UBound(ar)
ar(i, 1) = 0
Next
Sq = "SELECT * FROM [" & s & p & f(x) & "].[$A1:iv] WHERE LEN([证券名称])"
Set Rs = Cn.Execute(Sq)
br = Rs.GetRows()
For j = 0 To UBound(br, 2)
br(0, j) = Split(br(0, j), ".")(0)
Next
ReDim cr(Rs.Fields.Count - 1, 0) As String
For j = 0 To Rs.Fields.Count - 1
If j > 1 Then cr(j, 0) = Mid(Rs.Fields(j).Name, 12, 10) Else cr(j, 0) = Rs.Fields(j).Name
Next
For j = 1 To UBound(br, 2)
For i = 2 To UBound(cr)
y = Dict(br(0, j) & "-" & cr(i, 0))
If y Then If Not IsNull(br(i, j)) Then ar(y, 1) = ar(y, 1) + Val(br(i, j))
Next
Next
Sheet2.Cells(2, 13 + x * 2).Resize(UBound(ar)) = ar
End If
Next
Cn.Close: Set Cn = Nothing: Set Rs = Nothing: Set Dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub |
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-8-15 14:59
楼主
