I'm creating a table in VBA within a loop and when I run the code a table is created.
But the next time I run it, an error comes up telling me that the table exists and the remainder of the code is not executed.
How can I have it overwrite the existing table (from the previous run)?
Here is my code:
Option Compare Database
Public Function createTables()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String
strSQL = "Select SKUS from SKUS"
Set db = CurrentDb()
Set rst = db.OpenRecordset(strSQL)
Set fld = rst.Fields("SKUS")
'MsgBox fld.Value
rst.MoveFirst
Do While Not rst.EOF
Set tdf = db.CreateTableDef(fld.Value)
Set fld = tdf.CreateField("SKUS", dbText, 30)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Count", dbInteger)
tdf.Fields.Append fld
db.TableDefs.Append tdf
rst.MoveNext
Loop
End Function
Can anyone help me out please?
Thanks!
I would simply delete the table before attempting to recreate it:
db.TableDefs.Delete fld.Value
You can check if the table exists with the following function.
Public Function TableExists(TabName As String) As Boolean
Dim db As DAO.Database
Dim Sdummy As String
Set db = CurrentDb()
On Error Resume Next
Sdummy = db.TableDefs(TabName).Name
TableExists = (Err.Number = 0)
End Function
If the function returns true, then issue following sql statement:
DROP TABLE SKUS
The usual method is to test then delete temp table, requiring more code and recordkeeping for calling procedures that run multiple maketables.
Here is a procedure that is all inclusive, gleaning the source table name from maketable, then deleting before recreating. Also returns number of new records.
Public Function fcnMakeTableForce(strMTQuery As String) As Integer
On Error GoTo ErrorExit
'Runs maketable, deleting the resulting temp table contained in the query (if it
'exists) beforehand. Also returns the number of records in new temp table
Dim dbs As Database
Dim strSQL As String
Set dbs = CurrentDb
'Get SQL from MakeTable
strSQL = dbs.QueryDefs(strMTQuery).sql
'Get target table from SQL:
intINTOPos = InStr(strSQL, "INTO [") + 5
intFROMPos = InStr(strSQL, "FROM [") - 3
strTargetTable = Mid(strSQL, intINTOPos + 1, intFROMPos - intINTOPos - 1)
'Clear target table if it exists
If (DCount("*", "MSysObjects", "[Name] = """ & strTargetTable & """")) > 0 Then
CurrentDb.TableDefs.Delete (strTargetTable)
End If
dbs.Execute strMTQuery
intRecordsAdded = DCount("*", strTargetTable)
fcnMakeTableForce = intRecordsAdded
NormalExit:
Exit Function
ErrorExit:
MsgBox "Error: " & Err.Description & vbCr & vbCr & "in Function: fcnMakeTableForce"
Resume NormalExit
End Function
Related
Any way I can run a select query within the immediate console of VBA Access 2010 (VBA 7.0)?
This worked for me with a query that return integers:
Public Sub runQuery(ByVal query As String)
Dim DB As DAO.Database: Set DB = CurrentDb()
Dim rst As DAO.Recordset: Set rst = DB.OpenRecordset(query)
Do While Not rst.EOF
Dim rowStr As String: rowStr = ""
Dim fld As Field
For Each fld In rst.Fields
rowStr = rowStr & fld & " "
Next fld
Debug.Print (rowStr)
rst.MoveNext
Loop
End Sub
Then call it from the immediate window:
runQuery "SELECT Foo, Bar FROM MyTable WHERE Foo < 42"
I created a query separately and now want to use VBA to read its records and then send certain fields of all rows in an email.
I am currently stuck on trying to extract all the rows from the recordset. I know how to do it for one record, but not with a dynamic recordset. Every week, the recordset could potentially have 1-10 (approx.) records. I had hoped to do this by dynamically reading all rows, saving the fields that I want into variables, and then adding that to the email body, but I arrived at an error.
I'm getting an error that says: Run-time error '3265': Item not found in this collection.
Does anyone know how to fix this error and how I can put all resulting rows of the recordset into the email body?
The code:
Private Sub Form_Timer()
'current_date variable instantiated in a module elsewhere
current_date = Date
'Using the Date function to run every Monday, regardless of the time of day
If current_date = (Date - (DatePart("w", Date, 2, 1) - 1)) Then
'MsgBox ("the current_date variable holds: " & current_date)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim varRecords As Variant
Dim intNumReturned As Integer
Dim intNumColumns As Integer
Dim intColumn As Integer
Dim intRow As Integer
Dim strSQL As String
Dim rst_jobnumber As String
Dim rst_bfloc As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
If rst.EOF Then
MsgBox "Null."
Else
'Found this part of the code online and not sure if I'm using it right.
varRecords = rst!GetRows(3)
intNumReturned = UBound(varRecords, 2) + 1
intNumColumns = UBound(varRecords, 1) + 1
For intRow = 0 To intNumReturned - 1
For intColumn = 0 To intNumColumns - 1
Debug.Print varRecords(intColumn, intRow)
Next intColumn
Next intRow
'End of code found online.
'rst.MoveFirst 'commenting this out because this query could potentially return multiple rows
rst_jobnumber = rst!job & "-" & rst!suffix
rst_bfloc = rst!Uf_BackflushLoc
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
'Dim oApp As Outlook.Application
'Dim oMail As MailItem
'Set oApp = CreateObject("Outlook.application")
'mail_body = "The following jobs do not have the special BF location set in Job Orders: " & rst_
'Set oMail = oApp.CreateItem(olMailItem)
'oMail.Body = mail_body
'oMail.Subject = "Blow Molding Jobs Missing BF Location"
'oMail.To = "something#something.com" 'in the future, create a function that finds all of the SC users' emails from their Windows user
'oMail.Send
'Set oMail = Nothing
'Set oApp = Nothing
End If
End If
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Try working with this code and see how it works for you. I was unsure if you were sending one email per or one email listing all (I assumed the latter)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strMessageBody As String
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset("qry_BMBFLoc")
strMessageBody = "The following jobs do not have the special BF location set in Job Orders: "
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
strMessageBody = strMessageBody & rst!job & "-" & rst!suffix & ","
rst.MoveNext
Loop
If Right(strMessageBody, 1) = "," Then strMessageBody = Left(strMessageBody, Len(strMessageBody)-1)
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
EDIT - not using dot operator
Replace
varRecords = rst!GetRows(3)
with
varRecords = rst.GetRows(3)
Do you have three rows in your recordset?
If not rst!GetRows(3) will return false - and then next line will fail when you try to use UBound.
A good example of how to implement GetRows
Another possibility is if you're trying to access a Field that's not in your recordset on a line that has rst!
I am trying to run a script that replaces all null values in a table with a constant value in MS Access 2007. I am fully aware that this can be done using an update query. But the requirement that I need to do that for all columns in one click. I figured that find/replace can do this, but still I would rather minimize any manual work in the process.
I tried using this code but when I try to run it, it just doesn't do anything. It doesn't even trigger an error.
Sub replacingnulls()
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("testtable", dbOpenTable)
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
rs.Edit
For Each fld In rs.Fields
If IsNull(fld.Value) Then
fld.Value = 555
End If
Next fld
rs.MoveNext
Loop
Else
MsgBox ("There are no records")
End If
rs.Close
End Sub
Call rs.Update to save the changes you made to the current record before moving to the next record.
Next fld
rs.Update ' <-- add this
rs.MoveNext
Instead of looping through the table rows and then through each field within each row, you could execute one UPDATE per field.
Const cstrTable As String = "testtable"
Dim db As DAO.Database
Dim fld As DAO.Field
Dim tdf As DAO.TableDef
Dim strUpdate As String
Set db = CurrentDb
Set tdf = db.TableDefs(cstrTable)
For Each fld In tdf.Fields
' Access will complain if you attempt an UPDATE on an autonumber field,
' so skip field with dbAutoIncrField attribute
If Not ((fld.Attributes And dbAutoIncrField) = dbAutoIncrField) Then
strUpdate = "UPDATE [" & cstrTable & "] SET [" & fld.Name & _
"] = 555 WHERE [" & fld.Name & "] Is Null;"
'Debug.Print strUpdate
db.Execute strUpdate, dbFailOnError
End If
Next
Beware that code will attempt to replace all Nulls with 555 regardless of the field's datatype. If all the fields are plain numbers, that may be fine. However a Date/Time field with Null would become Jul 8 1901 00:00:00. OTOH, your recordset approach would do the same thing ... so if it's OK there, it should be OK here, too.
I am trying to create a new table with a few field on vba for Access 2000. I am able to create the table and a field when the data type of the field is Text But i need it to be Number. when I am changing the data type from Text to Number it gives me the error Data Type Conversion Error. Any Help would be Appreciated. Thanks
Public Sub CreateNewDB()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
'Initialize the Contractor table
Set db = CurrentDb()
Set tdf = db.CreateTableDef("new test table")
'Specify the fields
With tdf
'Create Sequence No Fied
' Set fld = .CreateField("Sequence No", dbText, 10) ' This works
Set fld = .CreateField("Sequence No", dbNumber, Long INteger) ' this gives me an error
.Fields.Append fld
End With
'save the table
db.TableDefs.Append tdf
Set fld = Nothing
Set tdf = Nothing
End Sub
try dbLong instead of dbNumber. Reference
Here's code to set the PK on a newly created table:
Set td = CurrentDb.CreateTableDef(sLocalTableName, dbAttachSavePWD, sRemoteTableName, sConnect)
CurrentDb.TableDefs.Append td
sExec = "CREATE UNIQUE INDEX PK ON [" & sLocalTableName & "]"
For iPK = 0 To iPkfldCount - 1
sPKfields = sPKfields & "[" & CurrentDb.TableDefs(sLocalTableName).Fields(iPK).Name & "],"
Next
sPKfields = Left(sPKfields, Len(sPKfields) - 1) ' strip trailing comma
CurrentDb.Execute sExec & " (" & sPKfields & ")"
after you set the PK fields, you shouldn't need to index or set to No Duplicates. All PKs work that way.
So I'd like to copy a linked table to a local one in code, structure and data in MS Access 2003.
Code being : VBA or C#. Or anything else for that matter..
UPDATE : I want the copy structure and data behaviour from ms access to keep the Primary Keys. If you copy a linked table, you can choose to paste it as 'structure and data (local table)'
It is that I want to achieve in code.
My understanding is that DAO does not support the decimal data type, but ADOX does. Here's an updated procedure that uses ADOX instead to copy the schema to a new table.
One interesting item of note: The OLEDB provider for Jet sorts the columns alphabetically rather than by ordinal position as explained in this KB article. I wasn't concerned about preserving the ordinal position, but you may be, in which case you can update this procedure to meet your needs.
In order for the ADOX version of the code to work, you'll need to set a reference to Microsoft ADO Ext. 2.x for DDL and Security (where x = version number; I used 2.8 to test this procedure). You'll also need a reference to ADO as well.
Public Sub CopySchemaAndData_ADOX(ByVal sourceTableName As String, ByVal destinationTableName As String)
On Error GoTo Err_Handler
Dim cn As ADODB.Connection
Dim cat As ADOX.Catalog
Dim sourceTable As ADOX.Table
Dim destinationTable As ADOX.Table
Set cn = CurrentProject.Connection
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
Set destinationTable = New ADOX.Table
destinationTable.Name = destinationTableName
Set sourceTable = cat.Tables(sourceTableName)
Dim col As ADOX.Column
For Each col In sourceTable.Columns
Dim newCol As ADOX.Column
Set newCol = New ADOX.Column
With newCol
.Name = col.Name
.Attributes = col.Attributes
.DefinedSize = col.DefinedSize
.NumericScale = col.NumericScale
.Precision = col.Precision
.Type = col.Type
End With
destinationTable.Columns.Append newCol
Next col
Dim key As ADOX.key
Dim newKey As ADOX.key
Dim KeyCol As ADOX.Column
Dim newKeyCol As ADOX.Column
For Each key In sourceTable.Keys
Set newKey = New ADOX.key
newKey.Name = key.Name
For Each KeyCol In key.Columns
Set newKeyCol = destinationTable.Columns(KeyCol.Name)
newKey.Columns.Append (newKeyCol)
Next KeyCol
destinationTable.Keys.Append newKey
Next key
cat.Tables.Append destinationTable
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & destinationTableName & " SELECT * FROM " & sourceTableName
CurrentDb.Execute sql
Err_Handler:
Set cat = Nothing
Set key = Nothing
Set col = Nothing
Set sourceTable = Nothing
Set destinationTable = Nothing
Set cn = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
Here's the original DAO procedure
Public Sub CopySchemaAndData_DAO(SourceTable As String, DestinationTable As String)
On Error GoTo Err_Handler
Dim tblSource As DAO.TableDef
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb
Set tblSource = db.TableDefs(SourceTable)
Dim tblDest As DAO.TableDef
Set tblDest = db.CreateTableDef(DestinationTable)
'Iterate over source table fields and add to new table
For Each fld In tblSource.Fields
Dim destField As DAO.Field
Set destField = tblDest.CreateField(fld.Name, fld.Type, fld.Size)
If fld.Type = 10 Then
'text, allow zero length
destField.AllowZeroLength = True
End If
tblDest.Fields.Append destField
Next fld
'Handle Indexes
Dim idx As Index
Dim iIndex As Integer
For iIndex = 0 To tblSource.Indexes.Count - 1
Set idx = tblSource.Indexes(iIndex)
Dim newIndex As Index
Set newIndex = tblDest.CreateIndex(idx.Name)
With newIndex
.Unique = idx.Unique
.Primary = idx.Primary
'Some Indexes are made up of more than one field
Dim iIdxFldCount As Integer
For iIdxFldCount = 0 To idx.Fields.Count - 1
.Fields.Append .CreateField(idx.Fields(iIdxFldCount).Name)
Next iIdxFldCount
End With
tblDest.Indexes.Append newIndex
Next iIndex
db.TableDefs.Append tblDest
'Finally, copy data from source to destination table
Dim sql As String
sql = "INSERT INTO " & DestinationTable & " SELECT * FROM " & SourceTable
db.Execute sql
Err_Handler:
Set fld = Nothing
Set destField = Nothing
Set tblDest = Nothing
Set tblSource = Nothing
Set db = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & ": " & Err.Description, vbCritical, Err.Source
End If
End Sub
try docmd.CopyObject or docmd.TransferDatabase
Create this query and execute it
SELECT * INTO MyNewTable FROM LinkedTableName
In VBA you can do
docmd.runsql "SELECT * INTO MyNewTable FROM LinkedTableName"
To keep the structure you would have to do DoCmd.TransferDatabase acImport