ADO法多文件汇总的一些细节问题。

13925099527

大家好，我在学习用ADO法汇总同目录下多个文件时候，遇到如下问题：
用下面的语句汇总得到的结果会有部分单元格内容丢失，
不知道是什么原因？希望能得到大家的帮助！
图片中黄色部分是丢失了单元格内容！
图片中蓝色部分是“数值”内容被转换成文本！

Sub ADO()
Application.ScreenUpdating = False
Application.EnableEvents = False
Mypath = ThisWorkbook.Path & "\"
MyFile = Dir(Mypath & "*.xls")
Dim cnn As Object
    Do While MyFile <> ""
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & Mypath & MyFile
    Set rs = cnn.openschema(20)
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                sh = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(sh, 1) = "$" Then
                        SQL = "select * from [" & sh & "] where 1=2"
                        Set rst = cnn.Execute(SQL)
                            If rst.Fields(0).Name <> "F1" Then
                                On Error Resume Next
                                SQL = "select 日期,产品名称,数量 from [" & sh & "]"
                                Sheet2.Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                                Exit Do
                            End If
                    End If
            End If
        rs.movenext
        Loop
    MyFile = Dir()
    Loop
rst.Close
rs.Close
cnn.Close
Set rst = Nothing
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

lsc900707

请更改红色行：
Sub ADO()
Application.ScreenUpdating = False
Application.EnableEvents = False
Mypath = ThisWorkbook.Path & "\"
MyFile = Dir(Mypath & "*.xls*")
Dim cnn As Object
     Do While MyFile <> ""
     Set cnn = CreateObject("adodb.connection")
     cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & Mypath & MyFile
     Set rs = cnn.openschema(20)
         Do Until rs.EOF
             If rs.Fields("TABLE_TYPE") = "TABLE" Then
                 sh = Replace(rs("TABLE_NAME").Value, "'", "")
                     If Right(sh, 1) = "$" Then
                         SQL = "select * from [" & sh & "] where 1=2"
                         Set rst = cnn.Execute(SQL)
                             If rst.Fields(0).Name <> "F1" Then
                                 On Error Resume Next
                                 SQL = "select 日期,产品名称,数量 from [" & sh & "]"
                                 Sheet2.Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                                 Exit Do
                             End If
                     End If
             End If
         rs.movenext
         Loop
     MyFile = Dir()
     Loop
rst.Close
rs.Close
cnn.Close
Set rst = Nothing
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

lsc900707

你的工作簿文件有两种不同版本的office文件，后缀为xls是97~03版的，07版以后都以xlsx为后缀，加个通配符解决。

zhaogang1960

Sub ADO()
Dim objWMI As Object
Const HKEY_LOCAL_MACHINE = &H80000002
Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office\" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
Application.ScreenUpdating = False
Application.EnableEvents = False
Mypath = ThisWorkbook.Path & "\"
MyFile = Dir(Mypath & "*.xls")
Dim cnn As Object
    Do While MyFile <> ""
    If InStr(ThisWorkbook.Name, MyFile) = 0 Then
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source=" & Mypath & MyFile
    Set rs = cnn.openschema(20)
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                sh = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(sh, 1) = "$" Then
                        SQL = "select * from [" & sh & "] where 1=2"
                        Set rst = cnn.Execute(SQL)
                            If rst.Fields(0).Name <> "F1" Then
                                SQL = "select 日期,产品名称,数量 from [" & sh & "]"
                                Sheet2.Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                                Exit Do
                            End If
                    End If
            End If
        rs.movenext
        Loop
    End If
    MyFile = Dir()
    Loop
rst.Close
rs.Close
cnn.Close
Set rst = Nothing
Set rs = Nothing
Set cnn = Nothing
With ActiveSheet.UsedRange
    .Value = .Value
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

zhaogang1960

ADO对数据要求很严格，不能随心所欲使用，否则会出现意想不到的错误
建议：
一、每一列格式相同，日期列就是日期，不能有其他文字或数字，名称列也不能有数字
二、标题行放在第一行

lsc900707

zhaogang1960 发表于 2016-8-6 20:05
ADO对数据要求很严格，不能随心所欲使用，否则会出现意想不到的错误
建议：
一、每一列格式相同，日期列 ...

赵老师，有的人根本不知道这些要求，拼凑一些数据来质疑代码，耽误您的宝贵时间，看着揪心。

张雄友

这是通过修改注册表实现的。

13925099527

zhaogang1960 发表于 2016-8-6 20:05
ADO对数据要求很严格，不能随心所欲使用，否则会出现意想不到的错误
建议：
一、每一列格式相同，日期列 ...

我懂了，谢谢赵老师！！
我从代码中没看出来问题在哪里才来提问的，
原来在判断“TABLE_TYPE”的时候，就已经判断好哪些是文字，哪些是数值啦。
真是太不可思议了！！！还可以根据列的内容判断列的基本类型。
谢谢赵老师，我会细心使用您教我的方法的！

每天加班2小时，周六加班10小时，就围着这些excel汇总转。
每月4000多份excel汇总，不敢出差错，谢谢赵老师反复耐心解答和教我知识

13925099527

lsc900707 发表于 2016-8-6 19:50
你的工作簿文件有两种不同版本的office文件，后缀为xls是97~03版的，07版以后都以xlsx为后缀，加个通配符解 ...

感谢！实在没时间系统学习这些知识！感谢教我。

送人亲

学习，学习，再学习