如何提取出多个Excel工作簿中相同字段的数据并生成新的文件？

小鹿一样

文件夹里总共有65个这样的工作簿，每个工作簿里只有一个sheet表，sheet表是以每个工作簿的名字命名的。里面A列字段都有重合的。

现在要把每个工作薄的A列 每一个相同字段如65027的数据都提取出来生成一个新的excel或文本文档并以字段名（如65027）为文件名。

因为数据量特别大，每个工作簿都是上万行，而且这些相同字段名的总共有400多个。

请教一下高手，这个应该如何在excel中实现。。感激不尽

zhaogang1960

请参考：
Sub 宏1()
    Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, p$, i&, n&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\结果\"
    If Dir(p, vbDirectory) = "" Then MkDir p
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            n = n + 1
            If n = 1 Then cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=" & File
            SQL = "select distinct f1 from [Excel 12.0;hdr=no;Database=" & File & ";].[" & Replace(File.Name, ".xlsx", "") & "$] where f1 is not null"
            Set rs = cnn.Execute(SQL)
            arr = rs.GetRows
            For i = 0 To UBound(arr, 2)
                SQL = "select * from [Excel 12.0;hdr=no;Database=" & File & ";].[" & Replace(File.Name, ".xlsx", "") & "$] where f1=" & arr(0, i)
                With Workbooks.Add(xlWBATWorksheet)
                    .ActiveSheet.Range("a1").CopyFromRecordset cnn.Execute(SQL)
                    .SaveAs p & arr(0, i) & ".xlsx"
                    .Close
                End With
            Next
        End If
    Next
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

zhaogang1960

结果放在“结果”文件夹中，请注意，如果65个工作簿中的A列有重复，则后面生成的工作簿会覆盖前面的
请测试附件
例子.rar (23.46 KB, 下载次数: 203)

2016-4-11 10:06 上传

点击文件名下载附件

小鹿一样

zhaogang1960 发表于 2016-4-11 10:07
结果放在“结果”文件夹中，请注意，如果65个工作簿中的A列有重复，则后面生成的工作簿会覆盖前面的
请测 ...

我把xlsm文件复制到目标文件夹下面 已经运行几个小时了，A列的字段是重复的 但重复字段所在行的数据不是重复的，年月日的日期不一样，这样的工作簿还会被覆盖吗？

zhaogang1960

小鹿一样 发表于 2016-4-11 13:43
我把xlsm文件复制到目标文件夹下面 已经运行几个小时了，A列的字段是重复的 但重复字段所在行的数据不是 ...

请多上传了几个工作簿，并模拟需要的效果

小鹿一样

zhaogang1960 发表于 2016-4-11 14:29
请多上传了几个工作簿，并模拟需要的效果

可能我没有表述清楚，就是原来的工作簿是 每一年 所有点 的数据，现在要的工作簿是 每个点 所有年 的数据。



我把示例更新了一下，麻烦这位老师指点一下，感激不尽~~~

zhaogang1960

小鹿一样 发表于 2016-4-11 15:42
可能我没有表述清楚，就是原来的工作簿是 每一年 所有点 的数据，现在要的工作簿是 每个点 所有年 的数据 ...

Sub 宏1()
    Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, p$, a, b, arr(), brr(1 To 100000, 4), i&, j&, n&, m&, c&, d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    p = ThisWorkbook.Path & "\结果\"
    If Dir(p, vbDirectory) = "" Then MkDir p
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count)
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            n = n + 1
            If n = 1 Then cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=" & File
            SQL = "select * from [Excel 12.0;hdr=no;Database=" & File & ";].[" & Replace(File.Name, ".xlsx", "") & "$] where f1 is not null"
            Set rs = cnn.Execute(SQL)
            arr(n) = rs.GetRows
            For i = 0 To UBound(arr(n), 2)
                d(arr(n)(0, i)) = d(arr(n)(0, i)) & "|" & n & "," & i
            Next
        End If
    Next
    k = d.keys
    t = d.items
    For l = 0 To d.Count - 1
        m = 0
        a = Split(t(l), "|")
        For i = 1 To UBound(a)
            m = m + 1
            b = Split(a(i), ",")
            n = b(0)
            c = b(1)
            For j = 0 To 4
                brr(m, j) = arr(n)(j, c)
            Next
        Next
        With Workbooks.Add(xlWBATWorksheet)
            .ActiveSheet.Range("a1").Resize(m, 5) = brr
            .SaveAs p & k(l) & ".xlsx"
            .Close
        End With
        Erase brr
    Next
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
    MsgBox "OK"
End Sub

zhaogang1960

请测试附件
更新后的例子.rar (79.1 KB, 下载次数: 388)

2016-4-11 19:17 上传

点击文件名下载附件

小鹿一样

zhaogang1960 发表于 2016-4-11 19:17
请测试附件

太厉害了！完美解决了我的问题，这个论坛真是太强大了。感谢高手！！