求大神写个东西。

overchen

我一个文件夹里，XLS的2000多个，但是我只要获取他O列里面的所有数据，他的格式全部一样，
我要提取D://123文件夹里的XLS表格里面所有的O列,并且保持成一个新的XLS,但是数据过多有可能保存下来超过65535行,自动放到另外一列.
懂的加我Q.、  2028521060 要钱也没事.

wzsy2_mrf

问题倒是不大，只是数据量太大的话，效率会成问题。而且会不会有一张表放不下的情况出现？

zhaogang1960

假设O列数据没有标题，ADO+数组法请参考：

1. Sub ADO加数组法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$
   
3.     Dim arr, brr(1 To 65536, 1 To 1), f As Boolean, i&, m&, n&
   
4.     Application.ScreenUpdating = False
   
5.     Application.StatusBar = "                           正在导入数据，请等待……"
   
6.     Cells.ClearContents
   
7.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
8.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
   
9.         If File.Name Like "*.xls" Then
   
10.             If File.Name <> ThisWorkbook.Name Then
    
11.                 If Not f Then
    
12.                     Set cnn = CreateObject("adodb.connection")
    
13.                     cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & File
    
14.                     SQL = "select f1 from [Sheet1$o:o] where f1 is not null"
    
15.                     f = True
    
16.                 Else
    
17.                     SQL = "select f1 from [Excel 8.0;hdr=no;Database=" & File & ";].[Sheet1$o:o] where f1 is not null"
    
18.                 End If
    
19.                 arr = cnn.Execute(SQL).GetRows
    
20.                 For i = 0 To UBound(arr, 2)
    
21.                     m = m + 1
    
22.                     If m > 65536 Then
    
23.                         Cells(1, n + 1).Resize(65536) = brr
    
24.                         m = 1
    
25.                         n = n + 1
    
26.                         Erase brr
    
27.                     End If
    
28.                     brr(m, 1) = arr(0, i)
    
29.                 Next
    
30.             End If
    
31.         End If
    
32.     Next
    
33.     Cells(1, n + 1).Resize(m) = brr
    
34.     Set File = Nothing
    
35.     Set Fso = Nothing
    
36.     cnn.Close
    
37.     Set cnn = Nothing
    
38.     Application.StatusBar = False
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

zhaogang1960

下面附件中有50个工作簿，请测试效果：
123.rar (1.99 MB, 下载次数: 98)

2014-6-29 18:59 上传

点击文件名下载附件

overchen

zhaogang1960 发表于 2014-6-29 18:59
下面附件中有50个工作簿，请测试效果：

怎么使用呢？

zhaogang1960

overchen 发表于 2014-6-30 13:38
怎么使用呢？

请看演示:

overchen

zhaogang1960 发表于 2014-6-30 15:54
请看演示:

额，我是wps是因为这个的问题吗。

zhaogang1960

overchen 发表于 2014-6-30 18:57
额，我是wps是因为这个的问题吗。

没有用过wps，应该是ADO不认识wps文件格式

张雄友

zhaogang1960 发表于 2014-6-30 18:59
没有用过wps，应该是ADO不认识wps文件格式

如果有标题怎么办？只要A1单元格一个标题就好了。

zhaogang1960

张雄友 发表于 2014-6-30 19:30
如果有标题怎么办？只要A1单元格一个标题就好了。

Sub ADO加数组法()
    Dim Fso As Object, File As Object, cnn As Object, SQL$
    Dim arr, brr(1 To 65535, 1 To 1), f As Boolean, i&, m&, n&
    Application.ScreenUpdating = False
    Application.StatusBar = "                           正在导入数据，请等待……"
    Cells.ClearContents
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xls" Then
            If File.Name <> ThisWorkbook.Name Then
                If Not f Then
                    Set cnn = CreateObject("adodb.connection")
                    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=yes';Data Source=" & File
                    SQL = "select 车间 from [Sheet1$o:o] where 车间 is not null"
                    f = True
                Else
                    SQL = "select 车间 from [Excel 8.0;hdr=yes;Database=" & File & ";].[Sheet1$o:o] where 车间 is not null"
                End If
                arr = cnn.Execute(SQL).GetRows
                For i = 0 To UBound(arr, 2)
                    m = m + 1
                    If m > 65535 Then
                        Cells(1, n + 1) = "车间"
                        Cells(2, n + 1).Resize(65535) = brr
                        m = 1
                        n = n + 1
                        Erase brr
                    End If
                    brr(m, 1) = arr(0, i)
                Next
            End If
        End If
    Next
    Cells(1, n + 1) = "车间"
    Cells(2, n + 1).Resize(m) = brr
    Set File = Nothing
    Set Fso = Nothing
    cnn.Close
    Set cnn = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub