在不打开工作薄的情况下，在总表汇总各分表数据

lily_z

大家好，向各位请教一个问题：
目前有1个汇总表，2个分表（1班和2班），分表的内容是各班的各科目的平均分。
请问在不打开分表工作薄的情况下，在汇总表直接提取相应数据？
另请知悉：这个例子里只有2个班，但实际上可能要几百个班，所以一个一个打开复制会比较麻烦，请各位高手给一个普适性较强的解决方式。谢谢！

1班

Desktop.zip (19.32 KB, 下载次数: 12)

2016-5-18 14:20 上传

点击文件名下载附件

aman1516

试试：
Private Sub CommandButton1_Click()
Dim Wb As Workbook, T1 As String, T2 As String
Dim fso, arr, ar1, ar2
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
arr = Range("A2:C" & Range("A65536").End(xlUp).Row)
T1 = ThisWorkbook.Path & "\1班.xlsx"
T2 = ThisWorkbook.Path & "\2班.xlsx"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(T1) Then
   Set Wb = GetObject(T1)
   With Wb.Sheets("1班")
        ar1 = .Range("A2:B" & .Range("A65536").End(xlUp).Row)
        Wb.Close False
   End With
Else
   MsgBox T1 & " 不存在或请检查文件名是否正确"
End If
If fso.FileExists(T2) Then
   Set Wb = GetObject(T2)
   With Wb.Sheets("2班")
        ar2 = .Range("A2:B" & .Range("A65536").End(xlUp).Row)
        Wb.Close False
   End With
Else
   MsgBox T2 & " 不存在或请检查文件名是否正确"
End If
For i = 1 To UBound(arr)
    For j = 1 To UBound(ar1)
        If arr(i, 1) = ar1(j, 1) Then
           arr(i, 2) = ar1(j, 2)
        End If
    Next
    For j = 1 To UBound(ar2)
        If arr(i, 1) = ar2(j, 1) Then
           arr(i, 3) = ar2(j, 2)
        End If
    Next
Next
Set Wb = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A2").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

aman1516

具体参考附件： Desktop.rar (30.03 KB, 下载次数: 35)

2016-5-18 22:06 上传

点击文件名下载附件

zhaogang1960

如果待汇总的工作簿较多，使用ADO法速度很快
Sub ADO加数组法()
    Dim Fso As Object, File As Object, cnn As Object, rs As Object, arr, brr(), i&, n&
    Set Fso = CreateObject("Scripting.FileSystemObject")
    ReDim brr(-1 To 1000, 0 To Fso.GetFolder(ThisWorkbook.Path).Files.Count - 1)
    brr(-1, 0) = "汇总"
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            n = n + 1
            brr(-1, n) = Replace(File.Name, ".xlsx", "")
            Set cnn = CreateObject("adodb.connection")
            cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & File
            Set rs = cnn.OpenSchema(20)
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        arr = cnn.Execute("[" & s & "]").GetRows
                        If n = 1 Then
                            For i = 0 To UBound(arr, 2)
                                brr(i, 0) = arr(0, i)
                            Next
                        End If
                        For i = 0 To UBound(arr, 2)
                            brr(i, n) = arr(1, i)
                        Next
                    End If
                    Exit Do
                End If
                rs.MoveNext
            Loop
        End If
    Next
    Cells.ClearContents
    [a1].Resize(i + 1, n + 1) = brr
    Set Fso = Nothing
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

zhaogang1960

程序假设每个工作簿仅有一个工作表，且A列科目完全相同
请测试附件
Desktop.rar (29.93 KB, 下载次数: 83)

2016-5-18 22:32 上传

点击文件名下载附件

LMY123

ADO加数组，FSO,OpenSchema(20)

补充内容 (2019-1-1 10:13):
同夹_多薄_单表_单列横向合并_首薄取A列_次薄取B列_ADO加数组法

opiona

http://club.excelhome.net/thread-1409141-1-1.html