不同格式的多工作簿多工作表汇总（导入）

zhaogang1960

张雄友 发表于 2013-6-30 10:45
会不会是版本原因(我用的是EXCEL2003），我把附件下载后重新执行ADO法，发现营业外支出的数据没有生成，和 ...

我用的也是Excel2003，ADO处理数据要求较严，加一个参数imex=1试试看
不同格式的多工作薄多工作表的汇总1.rar (101.37 KB, 下载次数: 116)

2013-6-30 10:53 上传

点击文件名下载附件

学不完用不尽

张雄友 发表于 2013-6-30 10:45
会不会是版本原因(我用的是EXCEL2003），我把附件下载后重新执行ADO法，发现营业外支出的数据没有生成，和 ...

看的仔细，ADO法存在此状况，2010、2011、2012三年的营业外支出没有。

学不完用不尽

zhaogang1960 发表于 2013-6-30 10:53
我用的也是Excel2003，ADO处理数据要求较严，加一个参数imex=1试试看

这次是真的正确了，一个字“完美”！

学不完用不尽

zhaogang1960 发表于 2013-6-30 10:53
我用的也是Excel2003，ADO处理数据要求较严，加一个参数imex=1试试看

赵老师，能否对科目和数据进行转职，设置成如下图的格式（有得寸进尺之嫌，请谅解！目的只有一个，就是想让程序尽量完美）：

zhaogang1960

学不完用不尽 发表于 2013-6-30 18:22
赵老师，能否对科目和数据进行转职，设置成如下图的格式（有得寸进尺之嫌，请谅解！目的只有一个，就是想 ...

1. Sub ADO加数组加字典()
   
2. '引用Microsoft Scripting Runtime
   
3.     Dim cnn As New ADODB.Connection
   
4.     Dim rs As ADODB.Recordset
   
5.     Dim rst As ADODB.Recordset
   
6.     Dim SQL$, arr_Field
   
7.     Dim p$, f$, arr, brr(1 To 65530, 1 To 6)
   
8.     Dim i&, j, v&, n&, r, d$, m$, y$, sh As Worksheet
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = Dir(p & "*.xls")
    
11.     Application.ScreenUpdating = False
    
12.     Do While f <> ""
    
13.         If f <> ThisWorkbook.Name Then
    
14.             Set cnn = New ADODB.Connection
    
15.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & p & f
    
16.             Set rs = cnn.OpenSchema(adSchemaTables)
    
17.             Do Until rs.EOF
    
18.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
19.                     shn = rs("TABLE_NAME").Value
    
20.                     If Right(shn, 1) = "$" Then
    
21.                         Set rst = cnn.Execute("[" & shn & "]")
    
22.                         If rst.Fields(0).Name = "单位" Then
    
23.                             y = Left$(f, 4)
    
24.                             Set rst = New ADODB.Recordset
    
25.                             SQL = "select * from [" & shn & "] where not 单位 is null"
    
26.                             rst.Open SQL, cnn, 1, 3
    
27.                             With rst
    
28.                                 ReDim arr_Field(1 To .Fields.Count - 1)
    
29.                                 For j = 1 To .Fields.Count - 1
    
30.                                     arr_Field(j) = .Fields(j).Name
    
31.                                 Next
    
32.                                 For i = 1 To .RecordCount
    
33.                                     w = .Fields(0).Value
    
34.                                     m = .Fields(1).Value
    
35.                                     d = .Fields(2).Value
    
36.                                     For j = 3 To .Fields.Count - 1
    
37.                                         v = v + 1
    
38.                                         brr(v, 1) = w
    
39.                                         brr(v, 2) = y
    
40.                                         brr(v, 3) = m
    
41.                                         brr(v, 4) = d
    
42.                                         brr(v, 5) = arr_Field(j)
    
43.                                         brr(v, 6) = .Fields(j).Value
    
44.                                     Next
    
45.                                     .MoveNext
    
46.                                 Next
    
47.                             End With
    
48.                         End If
    
49.                     End If
    
50.                 End If
    
51.                 rs.MoveNext
    
52.             Loop
    
53.         End If
    
54.         f = Dir
    
55.     Loop
    
56.     Cells.ClearContents
    
57.     [a1:f1] = Array("单位", "年", "月份", "店别", "科目", "数据")
    
58.     [a2].Resize(v, 6) = brr
    
59.     rs.Close
    
60.     Set rs = Nothing
    
61.     rst.Close
    
62.     Set rst = Nothing
    
63.     cnn.Close
    
64.     Set cnn = Nothing
    
65.     Application.ScreenUpdating = True
    
66. End Sub
    

复制代码

zhaogang1960

请看附件
不同格式的多工作薄多工作表的汇总1.rar (176.03 KB, 下载次数: 164)

2013-6-30 18:59 上传

点击文件名下载附件

学不完用不尽

zhaogang1960 发表于 2013-6-30 19:00
请看附件

谢谢赵老师！
这样利用透视表对数据进行后期处理就方便多啦。

学不完用不尽

zhaogang1960 发表于 2013-6-30 18:59

套用到其他表中，科目字段中出现好多F项，怎么解决呢？

zhaogang1960

学不完用不尽 发表于 2013-6-30 22:00
套用到其他表中，科目字段中出现好多F项，怎么解决呢？

出现F1、F2……等无效字段名？加个判断：

1. Sub ADO加数组加字典()
   
2. '引用Microsoft Scripting Runtime
   
3.     Dim cnn As New ADODB.Connection
   
4.     Dim rs As ADODB.Recordset
   
5.     Dim rst As ADODB.Recordset
   
6.     Dim SQL$, arr_Field
   
7.     Dim p$, f$, arr, brr(1 To 65530, 1 To 6)
   
8.     Dim i&, j, v&, n&, r, d$, m$, y$, sh As Worksheet
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = Dir(p & "*.xls")
    
11.     Application.ScreenUpdating = False
    
12.     Do While f <> ""
    
13.         If f <> ThisWorkbook.Name Then
    
14.             Set cnn = New ADODB.Connection
    
15.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & p & f
    
16.             Set rs = cnn.OpenSchema(adSchemaTables)
    
17.             Do Until rs.EOF
    
18.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
19.                     shn = rs("TABLE_NAME").Value
    
20.                     If Right(shn, 1) = "$" Then
    
21.                         Set rst = cnn.Execute("[" & shn & "]")
    
22.                         If rst.Fields(0).Name = "单位" Then
    
23.                             y = Left$(f, 4)
    
24.                             Set rst = New ADODB.Recordset
    
25.                             SQL = "select * from [" & shn & "] where not 单位 is null"
    
26.                             rst.Open SQL, cnn, 1, 3
    
27.                             With rst
    
28.                                 ReDim arr_Field(1 To .Fields.Count - 1)
    
29.                                 For j = 1 To .Fields.Count - 1
    
30.                                     arr_Field(j) = .Fields(j).Name
    
31.                                 Next
    
32.                                 For i = 1 To .RecordCount
    
33.                                     w = .Fields(0).Value
    
34.                                     m = .Fields(1).Value
    
35.                                     d = .Fields(2).Value
    
36.                                     For j = 3 To .Fields.Count - 1
    
37.                                         If Left$(arr_Field(j), 1) <> "F" Then
    
38.                                             v = v + 1
    
39.                                             brr(v, 1) = w
    
40.                                             brr(v, 2) = y
    
41.                                             brr(v, 3) = m
    
42.                                             brr(v, 4) = d
    
43.                                             brr(v, 5) = arr_Field(j)
    
44.                                             brr(v, 6) = .Fields(j).Value
    
45.                                         End If
    
46.                                     Next
    
47.                                     .MoveNext
    
48.                                 Next
    
49.                             End With
    
50.                         End If
    
51.                     End If
    
52.                 End If
    
53.                 rs.MoveNext
    
54.             Loop
    
55.         End If
    
56.         f = Dir
    
57.     Loop
    
58.     Cells.ClearContents
    
59.     [a1:f1] = Array("单位", "年", "月份", "店别", "科目", "数据")
    
60.     [a2].Resize(v, 6) = brr
    
61.     rs.Close
    
62.     Set rs = Nothing
    
63.     rst.Close
    
64.     Set rst = Nothing
    
65.     cnn.Close
    
66.     Set cnn = Nothing
    
67.     Application.ScreenUpdating = True
    
68. End Sub
    

复制代码

gemeng25569

太强悍了！羡慕！