求高手帮忙写段代码，要求批量跨文件引用一个工作簿的个别特定单元格

315297781

zhaogang1960 发表于 2013-12-19 16:47
请上传出错的那几个工作簿分析一下

不好意思，看出来哪里错 了，那几个表里边多 了个 sheet，不好意思，不过为什么不能生成全年的呢，只有前边112天的，不好意思，麻烦你了，刚才又看出来是我的问题，从4-22开始后边的所有日报文件格式变成了.xls，之前的都是.xlsx,真的很抱歉，我还是改改文件的后缀再试试吧，应该没有问题了{:soso_e143:}

zhaogang1960

315297781 发表于 2013-12-19 17:03
不好意思，看出来哪里错 了，那几个表里边多 了个 sheet，不好意思，不过为什么不能生成全年的呢，只有前 ...

再修改一下，循环工作簿中所有工作表，判断C6有数字时再退出循环：

1. Sub Macro1()
   
2.     Dim Fso As Object, sFileType$, i&, j&, m&, n&, na$, brr(), arrf$(), mf&, temp
   
3.     Dim cnn As Object, rs As Object, SQL$, s$
   
4.     Application.ScreenUpdating = False
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     sFileType = "*.xlsx"
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ReDim brr(1 To mf, 1 To 2)
   
9.     For i = 1 To mf
   
10.         Set cnn = CreateObject("adodb.connection")
    
11.         cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='excel 12.0;hdr=no';Data Source=" & arrf(i)
    
12.         Set rs = cnn.OpenSchema(20) 'adSchemaTables
    
13.         Do Until rs.EOF
    
14.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
15.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
16.                 If Right(s, 1) = "$" Then
    
17.                     brr(i, 1) = Replace(Mid(arrf(i), InStrRev(arrf(i), "") + 1), "销售日报.xlsx", "")
    
18.                     SQL = "select * from [" & s & "c6:c6]"
    
19.                     temp = cnn.Execute(SQL)(0)
    
20.                     If Not IsNull(temp) Then
    
21.                         If IsNumeric(temp) Then
    
22.                             brr(i, 2) = temp
    
23.                             Exit Do
    
24.                         End If
    
25.                     End If
    
26.                 End If
    
27.             End If
    
28.             rs.MoveNext
    
29.         Loop
    
30.     Next
    
31.     [a1].CurrentRegion.Offset(1).ClearContents
    
32.     [a2].Resize(i - 1, 2) = brr
    
33.     Set Fso = Nothing
    
34.     rs.Close
    
35.     Set rs = Nothing
    
36.     cnn.Close
    
37.     Set cnn = Nothing
    
38.     Application.ScreenUpdating = True
    
39. End Sub

复制代码

zhaogang1960

下面附件中2013-1-1销售日报插入了2个空表，请测试：
求助.rar (112.86 KB, 下载次数: 16)

2013-12-19 17:25 上传

点击文件名下载附件

315297781

zhaogang1960 发表于 2013-12-19 16:12
请测试：

请教版主，之前的两个问题我都搞明白了，一个是因为我部分表格有2个sheet，另一个是因为我的文件格式不统一，4月21号之前的日报格式是.xlsx，4月22号之后的日报格式是.xls，所以会出现错误，我现在把所有文件的日报格式都该成了.xls，然后把这段代码的里出现两次的.xlsx替换成了.xls，再运行就出现了错误了，麻烦您给指点一下，现在就差格式的问题了，之前是我做的不够规范，实在不好意思

zhaogang1960

315297781 发表于 2013-12-19 17:35
请教版主，之前的两个问题我都搞明白了，一个是因为我部分表格有2个sheet，另一个是因为我的文件格式不统 ...

sFileType = "*.xlsx"改为
sFileType = "*.xls*"

315297781

我按照您的替换了格式，再执行就出现“外部表格不是预期的格式”,这个怎么破？是不是因为该格式以后打开文件的这个提示

zhaogang1960

315297781 发表于 2013-12-19 17:49
我按照您的替换了格式，再执行就出现“外部表格不是预期的格式”,这个怎么破？是不是因为该格式以后打开文件 ...

如果你的工作簿是从某些软面中导出来的，可能是老式工作簿
请上传出错工作簿分析一下

315297781

zhaogang1960 发表于 2013-12-19 17:57
如果你的工作簿是从某些软面中导出来的，可能是老式工作簿
请上传出错工作簿分析一下

报表都是手工作的，可能是不同的人用的excel版本不同

zhaogang1960

315297781 发表于 2013-12-19 18:10
报表都是手工作的，可能是不同的人用的excel版本不同

1. Sub Macro1()
   
2.     Dim Fso As Object, sFileType$, i&, j&, m&, n&, na$, brr(), arrf$(), mf&, temp
   
3.     Dim cnn As Object, rs As Object, SQL$, s$
   
4.     Application.ScreenUpdating = False
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     sFileType = "*.xls*"
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ReDim brr(1 To mf, 1 To 2)
   
9.     For i = 1 To mf
   
10.         Set cnn = CreateObject("adodb.connection")
    
11.         cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='excel 12.0;hdr=no';Data Source=" & arrf(i)
    
12.         Set rs = cnn.OpenSchema(20) 'adSchemaTables
    
13.         Do Until rs.EOF
    
14.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
15.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
16.                 If Right(s, 1) = "$" Then
    
17.                     brr(i, 1) = Replace(Replace(Mid(arrf(i), InStrRev(arrf(i), "") + 1), "销售日报.xls", ""), "销售日报.xlsx", "")
    
18.                     SQL = "select * from [" & s & "c6:c6]"
    
19.                     temp = cnn.Execute(SQL)(0)
    
20.                     If Not IsNull(temp) Then
    
21.                         If IsNumeric(temp) Then
    
22.                             brr(i, 2) = temp
    
23.                             Exit Do
    
24.                         End If
    
25.                     End If
    
26.                 End If
    
27.             End If
    
28.             rs.MoveNext
    
29.         Loop
    
30.     Next
    
31.     [a1].CurrentRegion.Offset(1).ClearContents
    
32.     [a2].Resize(i - 1, 2) = brr
    
33.     Set Fso = Nothing
    
34.     rs.Close
    
35.     Set rs = Nothing
    
36.     cnn.Close
    
37.     Set cnn = Nothing
    
38.     Application.ScreenUpdating = True
    
39. End Sub
    
40. 
    
41. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    
42.     Dim Folder As Object
    
43.     Dim SubFolder As Object
    
44.     Dim File As Object
    
45.     Set Folder = Fso.GetFolder(sPath)
    
46.     If sPath <> ThisWorkbook.Path Then
    
47.         For Each File In Folder.Files
    
48.             If File.Name Like sFileType Then
    
49.                 mf = mf + 1
    
50.                 ReDim Preserve arrf(1 To mf)
    
51.                 arrf(mf) = File
    
52.             End If
    
53.         Next
    
54.     End If
    
55.     If Folder.SubFolders.Count > 0 Then
    
56.         For Each SubFolder In Folder.SubFolders
    
57.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
58.         Next
    
59.     End If
    
60.     Set Folder = Nothing
    
61.     Set File = Nothing
    
62.     Set SubFolder = Nothing
    
63. End Sub
    

复制代码

zhaogang1960

不是格式的问题，是把2007或以上文件后缀xlsx人为的修改成了xls，不用管它，按照2007文件对待即可：
Desktop.rar (46.88 KB, 下载次数: 13)

2013-12-19 18:25 上传

点击文件名下载附件