高手快来呀，Excel中如何跨工作簿寻找数据，并刷新现有数据

ljd15366

各位大侠：      

      EXCEL表格中，我想在《A学生总工作簿》中建立一个VBA代码，通过A列的学生编码，找到D列和F列对应的新数据。D列和F列的新数据在其他的五个工作簿中。（该学生编码是唯一的，不会同时出现的另外五个工作簿中），找到分布另外五个工作簿中对应的数据后，就将《A学生总工作簿》中原有的D列和F列数据刷新。

        一共有六个工作簿，其中一个为主工作簿名称是《A学生总工作簿》和五个从属性质的工作簿的名称分别为：《B一年级工作簿》、《C二年级工作簿》、《D三年级工作簿》、《E四年级工作簿》、《F五年级工作簿》。

       每个工作簿的的数据都在各自的Sheet1中，每个工作簿中的工作表都从第二行开始，第一行有另外用途。

      另外六个工作簿都在 D盘，文件夹名称为：学生VBA代码测试，还有在实际使用中，这些表格可能正在被使用，也可能没有被打开。如果正在使用的可以先保存，或者不予理会，从后台进行刷新。

     该代码只对这三列的数据有效，不能影响其他数列的数据

ljd15366

太难了吗？高手都去哪了

ljd4895

1. Sub 汇总成绩()
   
2. Dim EAPP As Excel.Application
   
3. Dim EWB As Excel.Workbook
   
4. Dim EWS As Excel.Worksheet
   
5. Application.ScreenUpdating = True '打开或关闭屏幕刷新效果。
   
6. 
   
7. Set EAPP = CreateObject("Excel.Application")
   
8. EAPP.Visible = False    '设置Excel是否可见，true为可见，false为不可见。
   
9. n = 0
   
10. For j = 1 To 5
    
11. Set EWB = EAPP.Workbooks.Open(ThisWorkbook.Path & "" & Mid("一二三四五", j, 1) & "年级工作簿.xlsx")
    
12. Set EWS = EWB.Worksheets("Sheet1")
    
13.     For i = 3 To Range("a65536").End(xlUp).Row
    
14.          If Range("a" & i).Value = EWS.Range("a" & i).Value Then Range("d" & i).Value = EWS.Range("d" & i).Value: Range("f" & i).Value = EWS.Range("f" & i).Value: n = n + 1
    
15.             Next i
    
16.     Set EWS = Nothing
    
17.     EAPP.ActiveWorkbook.Close savechanges:=True '保存所做更改。
    
18.     Set EWB = Nothing
    
19. Next j
    
20. MsgBox n & "名学生的成绩汇总完毕，正在关闭使用过的表格，请稍等！如果出现问题，请点击“取消”！"
    
21.     EAPP.Quit '本来应该把Next j放在本行之后的，但是，结束应用的时候，总是出错，有待继续排查原因。
    
22. 
    
23.     Set EAPP = Nothing   
    
24. End Sub

复制代码

上述过程执行到excel_App.Quit时，总是报错，不知道是什么原因，请各位大神帮忙解决。
还有，我找不到更好的遍历同一个目录下的所有工作簿的更好的方法，只能使用如下笨拙方法：
For j = 1 To 5
Set EWB = EAPP.Workbooks.Open(ThisWorkbook.Path & "\" & Mid("一二三四五", j, 1) & "年级工作簿.xlsx")
还须烦请大神们指教一些更加高级的方法了！谢谢！

魂断蓝桥

Sub a()
Dim cnn As Object, rs As Object, SQL$, d, Mypath$, MyName$, arr, brr(1 To 600, 1 To 2), i, m As Integer
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set rs = CreateObject("adodb.Recordset")
Mypath = ThisWorkbook.Path & "\"
MyName = Dir(Mypath & "*.xlsx")
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyName
        SQL = "select 学生编码,数学,化学 from [sheet1$a2:f] where 学生编码 is not null"
        rs.Open SQL, cnn, 1, 1
        If rs.RecordCount > 0 Then
            arr = cnn.Execute(SQL).GetRows
                For i = 0 To UBound(arr, 2)
                    m = m + 1
                    d(arr(0, i)) = m
                    brr(m, 1) = arr(1, i)
                    brr(m, 2) = arr(2, i)
                Next
        End If
    End If
    MyName = Dir()
    rs.Close
Loop
cnn.Close
Set rs = Nothing
Set cnn = Nothing
arr = [a2].CurrentRegion
[a2:f999].ClearContents
For i = 2 To UBound(arr)
    If Len(d(arr(i, 1))) > 0 Then
        arr(i, 4) = brr(d(arr(i, 1)), 1)
        arr(i, 6) = brr(d(arr(i, 1)), 2)
    End If
Next
Set d = Nothing
[a2].Resize(UBound(arr), 6) = arr
Application.ScreenUpdating = True
End Sub

ljd15366

魂断蓝桥 发表于 2014-10-21 13:08
Sub a()
Dim cnn As Object, rs As Object, SQL$, d, Mypath$, MyName$, arr, brr(1 To 600, 1 To 2), i,  ...

代码复制后运行时显示运行时错误‘91’，对象变量或with块变量未设置。能帮忙再改改吗，代码红色的部分有点问题
Sub a()
Dim cnn As Object, rs As Object, SQL$, d, Mypath$, MyName$, arr, brr(1 To 600, 1 To 2), i, m As Integer
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set rs = CreateObject("adodb.Recordset")
Mypath = ThisWorkbook.Path & "\"
MyName = Dir(Mypath & "*.xlsx")
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyName
        SQL = "select 学生编码,数学,化学 from [sheet1$a2:f] where 学生编码 is not null"
        rs.Open SQL, cnn, 1, 1
        If rs.RecordCount > 0 Then
            arr = cnn.Execute(SQL).GetRows
                For i = 0 To UBound(arr, 2)
                    m = m + 1
                    d(arr(0, i)) = m
                    brr(m, 1) = arr(1, i)
                    brr(m, 2) = arr(2, i)
                Next
        End If
    End If
    MyName = Dir()
    rs.Close
Loop
cnn.Close
Set rs = Nothing
Set cnn = Nothing
arr = [a2].CurrentRegion
[a2:f999].ClearContents
For i = 2 To UBound(arr)
    If Len(d(arr(i, 1))) > 0 Then
        arr(i, 4) = brr(d(arr(i, 1)), 1)
        arr(i, 6) = brr(d(arr(i, 1)), 2)
    End If
Next
Set d = Nothing
[a2].Resize(UBound(arr), 6) = arr
Application.ScreenUpdating = True
End Sub

魂断蓝桥

ljd15366 发表于 2014-10-21 18:29
代码复制后运行时显示运行时错误‘91’，对象变量或with块变量未设置。能帮忙再改改吗，代码红色的部分有 ...

屏蔽那句代码

ljd4895

运行时出现错误如图所示，请各位排查一下原因，谢谢！

shinyolive

Sub 汇总成绩()
Dim EAPP As Excel.Application
Dim EWB As Excel.Workbook
Dim EWS As Excel.Worksheet
Application.ScreenUpdating = True

这个测的怎么样了？

LMY123

arr = cnn.Execute(SQL).GetRows