Const Jet10 = 1
Const Jet11 = 2
Const Jet20 = 3
Const Jet3x = 4
Const Jet4x = 5
     
Sub CreateNewMDB(FileName, Format)
    ‘From http://www.motobit.com/tips/detpg_createmdb/
   
    Dim Catalog As Object
    Set Catalog = CreateObject(“ADOX.Catalog”)
    Catalog.Create “Provider=Microsoft.Jet.OLEDB.4.0;” & _
       “Jet OLEDB:Engine Type=” & Format & _
      “;Data Source=” & FileName
End Sub
 
Sub MakeJetDB()
 
    ‘Create Access2000 database
   CreateNewMDB “C:a2000.mdb”, Jet4x
End Sub
 
Sub CreateTblinDb()
       
    ‘creates a table in the database
   
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim sSQL As String
   
    ‘create the table with autonumber, primary key OrderID and
   ‘some other fields
   sSQL = “CREATE TABLE Orders (“ & _
        “OrderID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, “ & _
        “OrderDate date, “ & _
        “CustId char(8), “ & _
        “Amount float)”
   
   
    Set cn = New ADODB.Connection
   
    cn.Open sCON
   
    cn.Execute sSQL
   
End Sub
 
Sub DeleteTblinDb()
    ‘Deletes a table in a database
   
    Dim cn As ADODB.Connection
    Dim sSQL As String
   
    ‘deletes the table called Orders
   sSQL = “DROP TABLE Orders”
   
    Set cn = New ADODB.Connection
   
    ‘sCON is a constant with a proper connection string
   cn.Open sCON
   
    cn.Execute sSQL
   
End Sub
 
Sub PutDataInTable()
    ‘Puts data from a spreadsheet into a table
   
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim sSQL As String
    Dim rRow As Range
    Dim rRng As Range
    Dim i As Long
   
    Set rRng = Sheet2.Range(“b2:d4”)
    Set cn = New ADODB.Connection
    cn.Open sCON
   
    ‘Loops through the rows and builds a SQL statement via a function
   For Each rRow In rRng.Rows
        sSQL = MakeInsertInto(“Orders”, rRow, False, Sheet2.Range(“b1:d1”))
        If Len(sSQL) > 0 Then
            cn.Execute sSQL
        End If
    Next rRow
   
    cn.Close
    Set cn = Nothing
   
End Sub
 
Function MakeInsertInto(ByVal sTable As String, _
    ByRef rRecord As Range, _
    Optional ByVal bAutoIncrement As Boolean = True, _
    Optional ByRef rHeader As Range) As String
       
    ‘Builds a string that’s a SQL statement to insert records into a table
   ‘sTable is the name of the table
   ‘rRecord is the range that contains all the value, one per field
   ‘bAutoIncrement is true if the first field is an autonumber
   ‘rHeader is range that contains the field names – to be used when
   ‘   you’re not inserting all the fields and you need to identify
   ‘   which values are for which fields
   
    Dim rCell As Range
    Dim sSQL As String
   
    sSQL = sSQL & “INSERT INTO “ & sTable & ” “
   
    ‘Add the fields portion of the sql statement if rHeader was supplied
   If Not rHeader Is Nothing Then
        ‘compare cell count of record with header.  If autoincrement, header should be
       ‘one greater than record
       If rRecord.Cells.Count <> rHeader.Cells.Count + CLng(bAutoIncrement) Then
            MakeInsertInto = “”
            Exit Function
        End If
       
        ‘add column names
       sSQL = sSQL & “(“
        For Each rCell In rHeader.Cells
            sSQL = sSQL & rCell.Value & “, “
        Next rCell
        sSQL = Left$(sSQL, Len(sSQL) – 2) & “) “
    End If
   
    sSQL = sSQL & “VALUES (“
   
    ‘If the first field is an autonumber, make the value default
   If bAutoIncrement Then
        sSQL = sSQL & “DEFAULT, “
    End If
   
    ‘Loop through the record and add the values to the sql statement
   For Each rCell In rRecord.Cells
        If rCell.NumberFormat = “@” Then  ‘force a number to be text
           sSQL = sSQL & “‘” & CleanField(rCell.Value) & “‘, “
                   
        ElseIf IsEmpty(rCell.Value) Or Not IsNumeric(rCell.Value) Then
            sSQL = sSQL & “‘” & CleanField(rCell.Value) & “‘, “
           
        Else
            sSQL = sSQL & rCell.Value & “, “
           
        End If
    Next rCell
   
    ‘get rid of the last comma-space sequence and close the paren
   sSQL = Left$(sSQL, Len(sSQL) – 2)
    sSQL = sSQL & “);”
   
    MakeInsertInto = sSQL
   
End Function
 
Function CleanField(sValue As String) As String
   
    Dim sTemp As String
   
    ‘double up quotes and underscores
   sTemp = Replace$(sValue, “‘”, “””)
    sTemp = Replace$(sTemp, “_”, “__”)
   
    CleanField = sTemp
   
End Function