Creating Access Database

[baha17]

Hi All,

I have too many numbers of users who use one particular excel file. Since sharing workbook is not very much reliable, I added a code which creates access database. All data actually stores on access data base. I found the code and way on one of the very good website which was mentioned on this board. Now what I wanted to create two tables on the same DB somehow I could not get it right. I kept on getting error saying: "cannot define field more than once". please have a look at the code below.Thank you very much for the help:
Baha

Option Explicit
Const TARGET_DB = "DB_Allocation.mdb"
Sub CreateDB_And_Table()
  Sheets("Copy").Select
    Dim cat As ADOX.Catalog
    Dim tbl, tbl2 As ADOX.Table
    Dim sDB_Path As String
    
    sDB_Path = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
    
    'delete the DB if it already exists
    On Error Resume Next
    Kill sDB_Path
    On Error GoTo 0
    
    'create the new database
    Set cat = New ADOX.Catalog
    cat.Create _
        "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & sDB_Path & ";"
    
    'create the table
    Set tbl = New ADOX.Table
    tbl.Name = "tblAllocation"
    tbl.Columns.Append "TblID", adInteger
    tbl.Columns.Append "TblName", adVarWChar, 10
    tbl.Columns.Append "PitName", adVarWChar, 8
    tbl.Columns.Append "DlrId", adDouble
    tbl.Columns.Append "DlrName", adVarWChar, 40
    tbl.Columns.Append "DlrSkill", adVarWChar, 90
    tbl.Columns.Append "DlrTime", adVarWChar, 10
    tbl.Columns.Append "SwgDlrId", adDouble
    tbl.Columns.Append "SwgDlrName", adVarWChar, 40
    tbl.Columns.Append "SwgDlrSkill", adVarWChar, 90
    tbl.Columns.Append "SwgDlrTime", adVarWChar, 10
    tbl.Columns.Append "SupId", adDouble
    tbl.Columns.Append "SupName", adVarWChar, 40
    tbl.Columns.Append "SupSkill", adVarWChar, 90
    tbl.Columns.Append "SupTime", adVarWChar, 10
    tbl.Columns.Append "SwgSupId", adDouble
    tbl.Columns.Append "SwgSupName", adVarWChar, 40
    tbl.Columns.Append "SwgSupSkill", adVarWChar, 90
    tbl.Columns.Append "SwgSupTime", adVarWChar, 10
    cat.Tables.Append tbl
    Set tbl2 = New ADOX.Table
    tbl2.Name = "tblStaffReq"
    tbl2.Columns.Append "ReqID", adInteger
    tbl2.Columns.Append "PitId", adDouble
    tbl2.Columns.Append "ReqDlr", adDouble
    tbl2.Columns.Append "Remarks", adVarWChar, 40
    tbl2.Columns.Append "ReqTime", adVarWChar, 8
    tbl2.Columns.Append "ReqSup", adDouble
    tbl2.Columns.Append "Remarks", adVarWChar, 40
    tbl2.Columns.Append "ReqTime", adVarWChar, 8
    cat.Tables.Append tbl2 'HERE I GOT THE ERROR
    Set cat = Nothing
    
    'now create the primary key
    Call CreatePrimaryKey("tblAllocation", "TblID")
    Call CreatePrimaryKey("tblStaffReq", "ReqID")
End Sub
Private Sub CreatePrimaryKey(strTblId As String, varPKColumn As Variant)
    Dim cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim idx As ADOX.Index
    Dim sDB_Path As String
    Dim MyConn
    
    sDB_Path = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
    
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
    
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
    
    'create the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
    
    Set tbl = cat.Tables(strTblId)
    
    'delete any existing primary keys
    For Each idx In tbl.Indexes
        If idx.PrimaryKey Then
            tbl.Indexes.Delete idx.Name
        End If
    Next idx
    
    'create a new primary key
    Set idx = New ADOX.Index
    With idx
        .PrimaryKey = True
        .Name = "PrimaryKey"
        .Unique = True
    End With
    
    'append the column
    idx.Columns.Append varPKColumn
    
    'append the index to the collection
    tbl.Indexes.Append idx
    tbl.Indexes.Refresh
    
    'clean up references
    Set cnn = Nothing
    Set cat = Nothing
    Set tbl = Nothing
    Set idx = Nothing
    
End Sub
Private Sub CreatePrimaryKey2(strReqID As String, varPKColumn As Variant)
    Dim cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim idx As ADOX.Index
    Dim sDB_Path As String
    Dim MyConn
    
    sDB_Path = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
    
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
    
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
    
    'create the catalog
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
    
    Set tbl = cat.Tables(strReqID)
    
    'delete any existing primary keys
    For Each idx In tbl.Indexes
        If idx.PrimaryKey Then
            tbl.Indexes.Delete idx.Name
        End If
    Next idx
    
    'create a new primary key
    Set idx = New ADOX.Index
    With idx
        .PrimaryKey = True
        .Name = "PrimaryKey"
        .Unique = True
    End With
    
    'append the column
    idx.Columns.Append varPKColumn
    
    'append the index to the collection
    tbl.Indexes.Append idx
    tbl.Indexes.Refresh
    
    'clean up references
    Set cnn = Nothing
    Set cat = Nothing
    Set tbl = Nothing
    Set idx = Nothing
    
End Sub

 

[pcc]

you are trying to add a 'Remarks' column twice to the same table - not allowed..

 

[baha17]

Oh boy,is that alli will check it out.
thanks

 

[baha17]

Hi Pcc,

Thank you very much for your answer. It worked, how could I be that careless))
have a good day
baha

 

[pcc]

Thanks for feedback. Good luck with your project.
Cheers