|
- Dim strPath As String, strFile As String
- ' With Application.FileDialog(msoFileDialogFolderPicker)
- ' .InitialFileName = ThisWorkbook.Path
- ' If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
- ' End With
- ' If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
-
- Dim Conn As Object
- Dim strConn As String, SQL As String, s As String
-
- Application.ScreenUpdating = False
-
- Set Conn = CreateObject("ADODB.Connection")
-
- s = "Excel 12.0;HDR=YES;Database="
- If Application.Version < 12 Then
- s = Replace(s, "12.0", "8.0")
- strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
- Else
- strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
- End If
- 'Conn.Open strConn & ThisWorkbook.FullName
-
- strPath = ThisWorkbook.Path & "\数据库\"
- strFile = Dir(strPath & "*.xls?")
-
- SQL = "INSERT INTO [Sheet1$] SELECT * FROM [" & s & ThisWorkbook.FullName & "].[Sheet1$A1:H2]"
-
- While Len(strFile)
- 'If strPath & strFile <> ThisWorkbook.FullName Then
- With Conn
- .Open strConn & strPath & strFile
- .Execute (SQL)
- .Close
- End With
- 'End If
- strFile = Dir
- Wend
-
- If Conn.State = 1 Then Conn.Close
- Set Conn = Nothing
-
- Application.ScreenUpdating = True
- Beep
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|