需要汇总200多张表的第一列

kuang5627

求大神帮助改一下，我需要汇总200多张表的第一列：

Sub lsftest()
Dim f, mf, i
Dim wk As Workbook, sht As Worksheet
ChDrive Left(ThisWorkbook.Path, 1)
ChDir ThisWorkbook.Path
f = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls),*.xls", Title:="请选择要汇总的文件", MultiSelect:=True)
On Error Resume Next
Application.ScreenUpdating = False
For Each mf In f
i = i + 1
    Set wk = GetObject(mf)
    Set sht = wk.Sheets("结果汇总")
    sht.Range("a9:v9").Copy Destination:=Sheets("sheet1").Cells(i, 1)
    wk.Close False
Next
Application.ScreenUpdating = True
MsgBox "汇总完成,共汇总了" & i & "个文件!"
End Sub

kuang5627

每一列的内容长度不一样，汇总表 可以 和 那200多张表一个文件夹

kuang5627

求大神帮助啊 ， 你也可以给一个别的代码

opiona

还是来个附件看看吧！！

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona() '//函数实例
   
8. Set Sh0 = Worksheets("汇总")
   
9. Arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)
   
10. For i = 0 To UBound(Arr)
    
11.    Irow = Sh0 / Range("A65536").End(3).Row + 1
    
12.       Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=no';data source=" & Arr(i)
    
13.    StrSQL = "SELECT * FROM [Sheet1$a9:V9]"
    
14.    Arr = GET_SQLCoon(StrSQL, Str_coon, False)
    
15.    Sh0.Range("A" & Irow).Resize(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1) = Arr
    
16. Next
    
17. 
    
18. End Sub
    
19. 
    
20. 'CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName    '//连接Excel2007
    
21. 'CN.Open "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';data source=" & ThisWorkbook.FullName      '//OFFICE2003
    
22. '*****************************************************************************************
    
23. '函数名：    GET_SQLCoon
    
24. '函数功能：  获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库
    
25. '返回值：    返回一个二维数组
    
26. '参数1：     StrSQL   字符类型   SQL查询语句
    
27. '参数2：     Str_coon 字符类型   数据库连接语句
    
28. '参数3：     Biaoti   可参数选   是否输出标题，默认带有标题
    
29. '使用方法：  Arr =  GET_SQLCoon(StrSQL,Str_coon,true)
    
30. '            Arr(0,1)  '//数组第一行为标题行，从i=1 开始是数据
    
31. '            Sh2.Range("A2").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
    
32. '*****************************************************************************************
    
33. Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
    
34. On Error Resume Next    ' 改变错误处理的方式。
    
35. Dim CN, RS
    
36.    Err.Clear
    
37.    Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    
38.    Set RS = CreateObject("adodb.recordset")
    
39.        CN.Open Str_coon
    
40.        RS.Open StrSQL, CN, 1, 3
    
41.        If RS.RecordCount > 0 Then '//如果找到数据
    
42.             If Biaoti = True Then
    
43.                  ReDim Arr(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
    
44.                      For a = 0 To RS.Fields.Count - 1  '//导入标题
    
45.                         Arr(0, a) = RS.Fields(a).Name
    
46.                      Next
    
47.                  For i = 0 To RS.RecordCount - 1  '//导入数据
    
48.                      For a = 0 To RS.Fields.Count - 1
    
49.                          Arr(i + 1, a) = RS.Fields(a).Value
    
50.                      Next a
    
51.                      RS.MoveNext
    
52.                  Next
    
53.             Else
    
54.                  ReDim Arr(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
    
55.                  For i = 0 To RS.RecordCount - 1  '//导入数据
    
56.                      For a = 0 To RS.Fields.Count - 1
    
57.                          Arr(i, a) = RS.Fields(a).Value
    
58.                      Next a
    
59.                      RS.MoveNext
    
60.                  Next
    
61.             End If
    
62.         Else '//如果没有找到数据
    
63.             ReDim Arr(1, 1)
    
64.             Arr(0, 0) = ""
    
65.         End If
    
66. 
    
67.   GET_SQLCoon = Arr
    
68.   CN.Close  '//关闭ADO连接
    
69.   Set RS = Nothing
    
70.   Set CN = Nothing  '//释放内存
    
71. End Function
    
72. 
    
73. 
    
74. '*******************************************************************************************************
    
75. '功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
    
76. '函数名：  FileAllArr
    
77. '参数1：   Filename    需查找的文件夹名 不含最后的""
    
78. '参数2：   FileFilter     需要过滤的文件名，可省略，默认为：[*.*]
    
79. '参数3：   Liwai           剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
    
80. '参数4：   Files           是否只要文件夹名，可省略，默认为：FALSE
    
81. '返回值：  一个字符型的数组
    
82. '使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false)
    
83. '作者:    北极狐工作室 QQ：14885553
    
84. '*******************************************************************************************************
    
85. Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal Files As Boolean = False) As String()
    
86.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
87.     Set Did = CreateObject("Scripting.Dictionary")
    
88.     Dic.Add (Filename & ""), ""
    
89.     i = 0
    
90.     Do While i < Dic.Count
    
91.         Ke = Dic.keys   '开始遍历字典
    
92.         MyName = Dir(Ke(i), vbDirectory)    '查找目录
    
93.         Do While MyName <> ""
    
94.             If MyName <> "." And MyName <> ".." Then
    
95.                 If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
96.                     Dic.Add (Ke(i) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
97.                 End If
    
98.             End If
    
99.             MyName = Dir    '继续遍历寻找
    
100.         Loop
     
101.         i = i + 1
     
102.     Loop
     
103.     Dim arrx() As String
     
104.     i = 0
     
105.     If Files = True Then   '//是否只输出文件夹名
     
106.       
     
107.         For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
     
108.             ReDim Preserve arrx(i)
     
109.             If Ke <> Filename & "" Then  '//自身文件夹除外
     
110.                 arrx(i) = Ke
     
111.                 i = i + 1
     
112.             End If
     
113.          Next
     
114.          FileAllArr = arrx
     
115.     Else
     
116.         For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
     
117.             MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
     
118.             Do While MyFileName <> ""
     
119.                If MyFileName <> Liwai Then '排除例外文件
     
120.                   ReDim Preserve arrx(i)
     
121.                   arrx(i) = Ke & MyFileName
     
122.                   i = i + 1
     
123.                End If
     
124.                 MyFileName = Dir
     
125.             Loop
     
126.         Next
     
127.         FileAllArr = arrx
     
128.     End If
     
129. End Function
     
130. '****************************************************************
     
131. 
     
132. 
     
133. 
     

复制代码

kuang5627

帮弄一下吧   如附件   有成千上万张表  需要全部取第一列到汇总表 的A列 累积向下取 就可以了  谢谢大神

kuang5627

  需要全部取第一列到汇总表 的A列

kuang5627

请大神们帮助一下啊

kuang5627

附件在5楼 求大神帮助啊

魂断蓝桥

Sub a()
Dim cnn As Object, rs, ts As Object, SQL$, Mypath$, MyName$, arr, brr(1 To 65536, 1 To 1), i, m As Integer
Mypath = ThisWorkbook.Path & "\"
MyName = Dir(Mypath & "*.xls")
Set ts = CreateObject("adodb.Recordset")
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 [工作簿$a1:A] where 网吧帐号 is not null"
        ts.Open SQL, cnn, 1, 1
            If ts.RecordCount > 0 Then
                Set rs = cnn.Execute(SQL)
                arr = rs.getRows
                    For i = 0 To UBound(arr, 2)
                        m = m + 1
                        brr(m, 1) = arr(0, i)
                    Next
            End If
        ts.Close
    End If
    MyName = Dir()
Loop
rs.Close
cnn.Close
Set ts = Nothing
Set rs = Nothing
Set cnn = Nothing
[a:a].ClearContents
[a1] = "网吧帐号"
[a2].Resize(m, 1) = brr
End Sub

kuang5627

运行 提示         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyName 这段有问题提错内容是“外部表不是预期的格式”