VBA实用技巧-导入excel

来源:www.accessoft.com 点击数:16401 　 | 收藏 | 复制

时　间:2015-11-24 00:13:04
作　者:Allen Lee ID：13894 城市：厦门
摘　要:导入excel
正　文:

Sub Button1_Click()
Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

'引用Microsoft ActiveX Data Objects 2.x Library
'引用Microsoft AD0 Ext 2.8 for DDL and Security
Dim cnn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim Cat As New ADOX.Catalog
Dim myPath As String
Dim p
Dim sh As Worksheet
Dim SQL As String
Dim F As Boolean
Dim wk As Workbook

myPath = ThisWorkbook.Path & "\"
myData = ThisWorkbook.Path & "\data.accdb"
p = Dir(myPath & "A list *.xls?")
Set wk = Workbooks.Open(ThisWorkbook.Path & "\" & p)
If Not wk Is Nothing Then
      If Dir(myData) = "" Then
         Cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
         Set Cat = Nothing
         F = True '数据库文件不存在标志
      End If

      cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myData
      For Each sh In Worksheets
         If Not F Then '数据库文件已经存在，先判断同名数据表是否存在，如果存在就删除它
            Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, sh.Name, Empty))
            If Not rs.EOF Then
                  SQL = "Drop TABLE " & sh.Name
                  cnn.Execute SQL
            End If
         End If
         SQL = "Select * INTO " & sh.Name & " FROM [Excel 12.0;Database=" & wk.FullName _
            & ";].[sheet1$" & Range("a1").CurrentRegion.Address(0, 0) & "]"
         cnn.Execute SQL

      Next
      MsgBox " 成功导入 ", vbInformation, " 导入数据库 "
      cnn.Close
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
      Set cnn = Nothing
Else
      MsgBox "无须更新"
End If
End Sub

Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店

【打印此文】【关闭窗口】