如何使用 DAO 的 MS Excel 中创建 MS Access 数据库

Sub DataToAccess()
' Declare variables.
Dim Db As database
Dim Rs As Recordset
Dim Td As TableDef
Dim Fd As Field
Dim x As Integer
Dim i As Integer
Dim f As Integer
Dim r As Integer
Dim c As Integer
Dim Message As String
Dim Title As String
Dim LastColumn As Integer
Dim NumberTest As Double
Dim StartCell As Object
Dim LastCell As Object
Dim Response
Dim CreateFieldFlag As Integer
Dim Flag As Integer
CreateFieldFlag = 0
Flag = 0
' Turn off Screen Updating.
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' Create the database.
' This line will create an Microsoft Access 2.0 database. To vary the
' version of the database, change the "dbVersion" constant.
' See "CreateDatabase" in online Help for more information.
' The database will be created in the same folder as the
' activeworkbook.
Set Db = workspaces(0).CreateDatabase(ActiveWorkbook.Path & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) _
& ".mdb", dbLangGeneral, dbVersion20)
' Loop through all the worksheets in the workbook.
For i = 1 To Worksheets.Count
' Select the "i th" worksheet and Cell "A1."
' In this example, you need column headers in the first row.
' These headers will become field names.
Worksheets(i).Select
Range("A1").Select
' If the ActiveCell is blank, open a message box.
If ActiveCell.Value = "" Then
Message = "There is no data in the active cell: " & _
ActiveSheet.Name & "!" & ActiveCell.Address & Chr(10) & _
"Please ensure that all your worksheets have data on " & _
"them " & Chr(10) & _
"and the column headers start in cell A1" & Chr(10) & _
Chr(10) & "This process will now end."
Title = "Data Not Found"
MsgBox Message, , Title
Exit Sub
End If
' Create a new Table, and use the Worksheet Name as the
' Table Name.
Set Td = Db.CreateTableDef(Worksheets(i).Name)
' Find the number of fields on the sheet and store the number
' of the last column in a variable.
Selection.End(xlToRight).Select
LastColumn = Selection.Column
' Select the current region. Then find what the address
' of the last cell is.
Selection.CurrentRegion.Select
Set LastCell = Range(Right(Selection.Address, _
Len(Selection.Address) - _
Application.Search(":", Selection.Address)))
' Go back to cell "A1."
Range("A1").Select
' Enter a loop that will go through the columns and
' create fields based on the column header.
For f = 1 To LastColumn
Flag = 0
' Enter a select case statement to determine
' the cell format.
Select Case Left(ActiveCell.Offset(1, 0).NumberFormat, 1)
Case "G"    'General format
' The "General" format presents a special problem.
' See above discussion for explanation
If ActiveCell.Value Like "*Zip*" Then
Set Fd = Td.CreateField(ActiveCell.Value, _
dbText)
Fd.AllowZeroLength = True
r = LastCell.Row - 1
Flag = 1
Else
If ActiveCell.Value Like "*Postal*" Then
Set Fd = Td.CreateField(ActiveCell.Value, _
dbText)
Fd.AllowZeroLength = True
r = LastCell.Row - 1
Flag = 1
End If
End If
' Set up a text to determine if the field contains
' "Text" or "Numbers."
For r = 1 To LastCell.Row - 1
If Flag = 1 Then r = LastCell.Row
CreateFieldFlag = 1
NumberTest = ActiveCell.Offset(r, 0).Value / 2
Next r
' If we get all the way through the loop without
' encountering an error, then all the values are
' numeric, and we assign the data type to be "dbDouble"
If Flag = 0 Then
Set Fd = Td.CreateField(ActiveCell.Value, dbDouble)
End If
' Check to see if the cell below is formatted as a date.
Case "m", "d", "y"
Set Fd = Td.CreateField(ActiveCell.Value, dbDate)
' Check to see if the cell below is formatted as currency.
Case "$", "_"
Set Fd = Td.CreateField(ActiveCell.Value, dbCurrency)
' All purpose trap to set field to text.
Case Else
Set Fd = Td.CreateField(ActiveCell.Value, dbText)
End Select
' Append the new field to the fields collection.
Td.Fields.Append Fd
' Move to the right one column.
ActiveCell.Offset(0, 1).Range("A1").Select
' Repeat the procedure with the next field (column).
Next f
' Append the new Table to the TableDef collection.
Db.tabledefs.Append Td
' Select Cell "A2" to start the setup for moving the data from
' the worksheet to the database.
Range("A2").Select
' Define the StartCell as the Activecell. All record addition
' will be made relative to this cell.
Set StartCell = Range(ActiveCell.Address)
' Open a recordset based on the name of the activesheet.
Set Rs = Db.OpenRecordset(Worksheets(i).Name)
' Loop through all the data on the sheet and add it to the
' recordset in the database.
For x = 0 To LastCell.Row - 2
Rs.AddNew
For c = 0 To LastColumn - 1
Rs.Fields(c) = StartCell.Offset(x, c).Value
Next c
Rs.Update
Next x
' Repeat the process for the next worksheet in the workbook.
Next i
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
Select Case Err
Case 3204   ' Database already exists.
Message = "There has been an error creating the database." & _
Chr(10) & _
Chr(10) & "Error Number: " & Err & _
Chr(10) & "Error Description: " & Error() & _
Chr(10) & _
Chr(10) & "Would you like to delete the existing" & _
"database:" & Chr(10) & _
Chr(10) & ActiveWorkbook.Path & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & _
".mdb"
Title = "Error in Database Creation"
Response = MsgBox(Message, vbYesNo, Title)
If Response = vbYes Then
Kill ActiveWorkbook.Path & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) -4) _
& ".mdb"
Message = ""
Title = ""
Resume
Else
Message = "In order to run this procedure you need" & _
Chr(10) & "to do ONE of the following:" & _
Chr(10) & _
Chr(10) & "1.  Move the existing database to a " & _
"different directory, or " & _
Chr(10) & "2.  Rename the existing database, or" & _
Chr(10) & "3.  Move the workbook to a different " & _
"directory, or" & _
Chr(10) & "4.  Rename the workbook"
Title = "Perform ONE of the following:"
MsgBox Message, , Title
Message = ""
Title = ""
Exit Sub
End If
' Check to see if the error was Type Mismatch. If so, set the
' file to dbText.
Case 13 ' Type mismatch.
If CreateFieldFlag = 1 Then
Set Fd = Td.CreateField(ActiveCell.Value, dbText)
Fd.AllowZeroLength = True
Flag = 1
r = LastCell.Row - 1
CreateFieldFlag = 0
Resume Next
Else
Message = "You have a ""Type Mismatch"" in the code" _
& Chr(10) _
& Chr(10) & "Error Number: " & Err _
& Chr(10) & "Error Description: " & Error() _
& Chr(10) _
& Chr(10) & "This procedure will close."
Title = "Type Mismatch"
MsgBox Message, , Title
Message = ""
Title = ""
End If
' For any other error, display the error.
Case Else
Message = "An error has occured in the procedure." _
& Chr(10) _
& Chr(10) & "Error Number: " & Err _
& Chr(10) & "Error Description: " & Error()
Title = "An error has occured"
MsgBox Message, , Title
Message = ""
Title = ""
End Select
End Sub