利用同个文件夹下多个excel文件的数据制作一张单独的数据汇总表

idiocx

我想利用同个文件夹下多个excel文件的数据制作一张单独的数据汇总表，文件夹分布如附件测试文件，测试文件中只列了2个月，实际做的时候要考虑12个月。
设想如下：
1、测试目录下有1个数据汇总表及12个月的文件夹；
2、每个月的文件夹中分别又分A产品跟B产品的文件夹；
3、每个产品文件夹中有15个公司的运费报表；
4、测试目录下的数据汇总表抓取12个月的文件夹的数据做分析；
5、数据汇总表需要抓取的选项如下：
5.1 在数据汇总表中自动添加四列分类（自动排序、抓取月份做时间分类、抓取公司名做公司分类、抓取产品名做产品分类）；
5.2 抓取全部表中的目的省份、目的地区、里程、月发车总数、总吨（立方）数、每吨（立方）平均运费
6、将以上数据自动生成排列到数据汇总表
7、补充一点，每一个运费报表均有设置密码......


哪位大侠帮帮忙？不然近2万行的数据会搞死人滴。先谢谢了！

LangQueS

建议先将多个文件中的数据汇合到同一个工作表中再做汇总。

关于使用Excel管理数据的基本方法请参考：
  
★Excel数据管理的一般规律★    http://club.excelhome.net/thread-287461-1-1.html

idiocx

LangQueS 发表于 2014-10-23 22:42
建议先将多个文件中的数据汇合到同一个工作表中再做汇总。

关于使用Excel管理数据的基本方法请参考：

版主好，我是想看看有没人能帮忙做个宏，两万多条数据合并工程量太大了。

idiocx

呃，昨天看错了，总的数据是4万多行，求大神出手呀。

魂断蓝桥

带密码，ADO不能直接连接，自己找个代码去除密码吧。

Sub a()
Dim MuLu As String
Dim myfile As String, ms As String
Dim brr, D, x
Dim i As Integer
Dim cnn As Object, rs As Object, SQL$, CRR, Arr(1 To 60000, 1 To 9), M As Integer
MuLu = ThisWorkbook.Path
Set D = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
If Left(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
D.Add MuLu, ""
i = 0
Do While i < D.Count
    brr = D.KEYS
    myfile = Dir(brr(i), vbDirectory)
    Do While myfile <> ""
        If myfile <> "." And myfile <> ".." Then
            If (GetAttr(brr(i) & myfile) And vbDirectory) = vbDirectory Then D.Add (brr(i) & myfile & "\"), ""
        End If
        myfile = Dir
    Loop
    i = i + 1
Loop
For Each x In D.KEYS
        myfile = Dir(x & "*.xls")
        Do While myfile <> "" And myfile <> ThisWorkbook.Name
                ms = ms & x & myfile
                    Set cnn = CreateObject("ADODB.Connection")
                    cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & ms
                    SQL = "select f2,f3,f4,f6,f7,f9 from [汇总表$a4:k] where f2 is not null"
                    Set rs = cnn.Execute(SQL)
                    CRR = rs.getRows
                        For i = 0 To UBound(CRR, 2)
                            M = M + 1
                            Arr(M, 1) = Left(myfile, InStr(myfile, "公司") + 1)
                            Arr(M, 2) = Replace(Left(myfile, InStr(myfile, "月")), Arr(M, 1), "")
                            Arr(M, 3) = Replace(Mid(x, InStrRev(Left(x, Len(x) - 1), "\") + 1), "\", "") ' 返回文件夹名称
                            Arr(M, 4) = CRR(0, i)
                            Arr(M, 5) = CRR(1, i)
                            Arr(M, 6) = CRR(2, i)
                            Arr(M, 7) = CRR(3, i)
                            Arr(M, 8) = CRR(4, i)
                            Arr(M, 9) = CRR(5, i)
                         Next
                ms = ""
                myfile = Dir
        Loop
Next
[a2:j9999] = ""
[b2].Resize(M, 9) = Arr
Set D = Nothing
Range("b2").CurrentRegion.Sort key1:=[c2], order1:=xlAscending, key2:=[d2], order2:=xlAscending, Header:=xlGuess
Range("A2") = 1
Range("A2").AutoFill Destination:=Range("A2").Resize(M), Type:=xlFillSeries
Application.ScreenUpdating = True
End Sub

idiocx

魂断蓝桥 发表于 2014-10-24 09:56
带密码，ADO不能直接连接，自己找个代码去除密码吧。

Sub a()

大神好！

刚才就测试文件进行测试，显示错误如下要怎么处理，我是小白。。。。



这一行是调试过程高亮标识黄色的代码。
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & ms
===================================================================

另外我要更更改目的省份、目的地区、里程、月发车总数、总吨（立方）数、每吨（立方）平均运费等的目标指向的单元格要从哪里修改，请大神科普，多谢！或者其他懂的大神教我！

魂断蓝桥

用你的文件没有问题

f1就是第一列，f2就是第二列，以此类推

测试.rar (179.35 KB, 下载次数: 17)

2014-10-24 16:44 上传

点击文件名下载附件

LMY123

CRR = rs.getRows