This question already has answers here:
Get all field names in Microsoft Access Table using SQL
(1 answer)
Get column names
(2 answers)
Closed 2 years ago.
How to get fieldnames or columnname of a table in msaccess using query?
Can someone help me to overcome this issue?
Like if i have table called "employee" i need to fetch the fieldnames(id,name,workstatus..etc) of employees alone not its records...Is any method to get this?
Thanks
Here is some code I have used in the past to keep track of things for audits etc. I cant take credit for it, I found it on the web ages ago
Sub GetField2Description()
'**********************************************************
'Purpose: 1) Deletes and recreates a table (tblFields)
' 2) Queries table MSysObjects to return names of
' all tables in the database
' 3) Populates tblFields
'Coded by: raskew
'Inputs: From debug window:
' Call GetField2Description
'Output: See tblFields
'**********************************************************
Dim db As Database, td As TableDef
Dim rs As Recordset, rs2 As Recordset
Dim Test As String, NameHold As String
Dim typehold As String, SizeHold As String
Dim fielddescription As String, tName As String
Dim n As Long, i As Long
Dim fld As Field, strSQL As String
n = 0
Set db = CurrentDb
' Trap for any errors.
On Error Resume Next
tName = "tblFields"
'Does table "tblFields" exist? If true, delete it;
docmd.SetWarnings False
docmd.DeleteObject acTable, "tblFields"
docmd.SetWarnings True
'End If
'Create new tblTable
db.Execute "CREATE TABLE tblFields(Object TEXT (55), FieldName TEXT (55), FieldType TEXT (20), FieldSize Long, FieldAttributes Long, FldDescription TEXT (20));"
strSQL = "SELECT MSysObjects.Name, MSysObjects.Type From MsysObjects WHERE"
strSQL = strSQL + "((MSysObjects.Type)=1)"
strSQL = strSQL + "ORDER BY MSysObjects.Name;"
Set rs = db.OpenRecordset(strSQL)
If Not rs.BOF Then
' Get number of records in recordset
rs.MoveLast
n = rs.RecordCount
rs.MoveFirst
End If
Set rs2 = db.OpenRecordset("tblFields")
For i = 0 To n - 1
fielddescription = " "
Set td = db.TableDefs(i)
'Skip over any MSys objects
If Left(rs!Name, 4) <> "MSys" And Left(rs!Name, 1) <> "~" Then
NameHold = rs!Name
On Error Resume Next
For Each fld In td.Fields
fielddescription = fld.Name
typehold = FieldType(fld.Type)
SizeHold = fld.Size
rs2.AddNew
rs2!Object = NameHold
rs2!FieldName = fielddescription
rs2!FieldType = typehold
rs2!FieldSize = SizeHold
rs2!FieldAttributes = fld.Attributes
rs2!FldDescription = fld.Properties("description")
rs2.Update
Next fld
Resume Next
End If
rs.MoveNext
Next i
rs.Close
rs2.Close
db.Close
End Sub
Function FieldType(intType As Integer) As String
Select Case intType
Case dbBoolean
FieldType = "dbBoolean" '1
Case dbByte
FieldType = "dbByte" '2
Case dbInteger
FieldType = "dbInteger" '3
Case dbLong
FieldType = "dbLong" '4
Case dbCurrency
FieldType = "dbCurrency" '5
Case dbSingle
FieldType = "dbSingle" '6
Case dbDouble
FieldType = "dbDouble" '7
Case dbDate
FieldType = "dbDate" '8
Case dbBinary
FieldType = "dbBinary" '9
Case dbText
FieldType = "dbText" '10
Case dbLongBinary
FieldType = "dbLongBinary" '11
Case dbMemo
FieldType = "dbMemo" '12
Case dbGUID
FieldType = "dbGUID" '15
End Select
End Function
Related
i am trying to get the frequency of terms within a collection of variable length strings.The context is descriptions in an Access database. Would prefer to keep the solution in VBA. Delimiter is " " (space) character
Dim db As DAO.Database
Set db = CurrentDb()
Call wordfreq
End Sub
Function wordfreq()
Dim myCol As Collection
Dim myArray() As String
Dim strArray As Variant
Dim strDescr, strTerm, strMsg As String
Dim i, j As Integer
Set myCol = New Collection
strDescr = "here it should accept the table and display the result in seperate table"
' db.Execute "select columns from table"
myArray = Split(strDescr, " ")
For Each strArray In myArray
On Error Resume Next
myCol.Add strArray, CStr(strArray)
Next strArray
For i = 1 To myCol.Count
strTerm = myCol(i)
j = 0
For Each strArray In myArray
If strArray = strTerm Then j = j + 1
Next strArray
'placeholder
strMsg = strMsg & strTerm & " --->" & j & Chr(10) & Chr(13)
Next i
'placeholder
'save results into a table
MsgBox strMsg
End Function
See an example below using a Scripting.Dictionary object.
Function wordfreq()
Dim objDict As Object
Dim myArray() As String
Dim strInput As String
Dim idx As Long
Set objDict = CreateObject("Scripting.Dictionary")
strInput = "here it should accept the table and display the result in seperate table"
myArray = Split(strInput, " ")
For idx = LBound(myArray) To UBound(myArray)
If Not objDict.Exists(myArray(idx)) Then
'Add to dictionary with a count of 1
objDict(myArray(idx)) = 1
Else
'Increment counter
objDict(myArray(idx)) = objDict(myArray(idx)) + 1
End If
Next
'Test it
Dim n As Variant
For Each n In objDict.Keys
Debug.Print "Word: " & n, " Count: " & objDict(n)
Next
End Function
Output:
'Word: here Count: 1
'Word: it Count: 1
'Word: should Count: 1
'Word: accept Count: 1
'Word: the Count: 2
'Word: table Count: 2
'Word: and Count: 1
'Word: display Count: 1
'Word: result Count: 1
'Word: in Count: 1
'Word: seperate Count: 1
Edit
The process:
Loop through the Input recordset.
Split the Description into words.
Check if the word exist in Dictionary and add or
increment.
Add the Keys (words) and Values (count) of the aforementioned
Dictionary to the Output table.
To achieve this two helper functions have been set up:
One loops through the description recordset and returns a
Dictionary object filled with unique words as Keys and their
count as Values.
The other takes the above Dictionaryobject and adds it to the Output table.
You need to change [TABLE] to the name of your Input and Output tables.
Option Explicit
Sub WordsFrequency()
On Error GoTo ErrTrap
Dim rs As DAO.Recordset
Set rs = CurrentDb().OpenRecordset("SELECT Description FROM [TABLE] WHERE Description Is Not Null;", dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
If AddDictionaryToTable(ToDictionary(rs)) Then
MsgBox "Completed successfully.", vbInformation
End If
Leave:
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub
' Returns Scripting.Dictionary object
Private Function ToDictionary(rs As DAO.Recordset) As Object
Dim d As Object 'Dictionary
Dim v As Variant 'Words
Dim w As String 'Word
Dim i As Long, ii As Long 'Loops
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To rs.RecordCount
v = Split(rs![Description], " ")
For ii = LBound(v) To UBound(v)
w = Trim(v(ii))
If Not d.Exists(w) Then d(w) = 1 Else d(w) = d(w) + 1
Next
rs.MoveNext
Next
Set ToDictionary = d
End Function
' Adds Dictionary object to table
Private Function AddDictionaryToTable(objDict As Object) As Boolean
On Error GoTo ErrTrap
Dim rs As DAO.Recordset
Dim n As Variant
Set rs = CurrentDb().OpenRecordset("[TABLE]")
With rs
For Each n In objDict.Keys
.AddNew
.Fields("Words").Value = n
.Fields("Counts").Value = objDict(n)
.Update
Next
End With
'all good
AddDictionaryToTable = True
Leave:
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
On Error GoTo 0
Exit Function
ErrTrap:
MsgBox Err.Description, vbCritical
Resume Leave
End Function
Could use a little help. Previously I have been using IIF statements to get this output but there are limitations to IIF and now am looking for a function (In MS Access) to meet the requirement.
Challenge: Need to search a row for a criteria (e.g. Title 00\Question..), if/when a match is found it returns the column name using a function withing a query (e.g. FieldCategorization(Title 00\Question). Click on links below to see table and desired output
Microsoft access table:
Desired output from query:
What I have so far searches the entire table, it doesn't seach a row-per-row basis:
Public Function FieldCategorization(TblName As String, Criteria As Long) As String
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset(TblName)
Dim fld As DAO.Field
' MyValue = 224803 ' T00 = Title 00\Question\First Name Text
' MyValue = 224814 ' AB00 = Abbreviation 00
MyValue = Criteria
'MsgBox "TblName: " & TblName & vbCrLf & "Criteria: " & Criteria
rs.MoveFirst
' Move through each row in the recordset
'Do While Not rs.EOF
For Each fld In rs.Fields
If fld = MyValue Then
FieldCategorization = fld.Name
End If
Next fld
rs.MoveNext
'Loop
End Function
Just did something similar today. The example below is super simplified, but I think it has all the elements you're looking for.
dim fld as fields
dim rst, rstW as recordset
MyValue = "Title 00\Question"
Set dbs = currentdB
Set rst = dbs.openrecordset ("table1")
Set rstW = dbs.openrecordset ("table2")
rst.movefirst
Do while not rst.eof
for each fld in rst.fields
if me(fld.name) = MyValue then
rstW.addnew
rstW!Title00 = fld.name
rstW.update
end if
next fld
rst.movenext
Loop
I've created a public function in Access. My goal is if the next business day is a holiday I'm calculating one extra day of interest for payoff purposes. Below is the working code I have. The issue I'm haveing is I'm dealing with over 35000 records and the time it takes to run the query is too long. If there is a better way of do this I will definitely give it a try. Thanks!
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
If rst("HolidayDate") = NextBusDay Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
rst.MoveNext
Loop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End Function
Here is one solution to avoid the opening the Holiday table 35,000 times. It will load all dates into an Array (only once), then use that array for comparing. But I am curious if your existing process ever worked correctly 100% of the time -- if that table contained more than one holiday? Specifically, when you read the holiday table (regardless of the sort order), then in your loop "If rst("HolidayDate") = NextBusDay Then", since you don't exit the loop if you get a match, your subroutine should always return the results of what happens when checking the last date in the table? Also I didn't find a Dim for NextBusDay, so I added it.
Option Compare Database
Option Explicit
Public blnSetArray As Boolean
Public dHolidays() As Date
Public iHolidays As Integer
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Dim i As Integer
Dim iLoop As Integer
Dim NextBusDay As Date
' Save an array of dates the first time
If blnSetArray = False Then
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
i = 0
If Not (rst.EOF And rst.BOF) Then
rst.MoveLast
rst.MoveFirst
iHolidays = rst.RecordCount
ReDim dHolidays(rst.RecordCount)
Do While Not rst.EOF
i = i + 1
dHolidays(i) = rst("HolidayDate")
rst.MoveNext
Loop
End If
blnSetArray = True
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End If
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
HolidayInterest = 0 ' Set as default
If iHolidays > 0 Then
For iLoop = 1 To iHolidays
If dHolidays(iLoop) = NextBusDay Then
HolidayInterest = Perdiem
Exit For ' No need to stay in loop
End If
Next iLoop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
End Function
Function MyTest()
blnSetArray = False
Debug.Print HolidayInterest(100#)
End Function
Apart from the Perdiem value you pass as an argument to your function, the only thing that will affect the return value of your function is the current system date as returned by Date. In other words, on any given day your function will always return either the Perdiem value or zero.
Therefore, we can use a Static variable named TheDateToday to hold the current date and you will only have to hit the [tbl_Holidays] table once on any given day:
Option Compare Database
Option Explicit
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim NextBusDay As Date
Static TheDateToday As Date, NextBusDayIsHoliday As Boolean
If CLng(TheDateToday) <> CLng(Date) Then
TheDateToday = Date
Select Case DatePart("w", TheDateToday)
Case 6
NextBusDay = DateAdd("d", 3, TheDateToday)
Case 7
NextBusDay = DateAdd("d", 2, TheDateToday)
Case Else
NextBusDay = DateAdd("d", 1, TheDateToday)
End Select
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", _
"PARAMETERS prmDate DateTime;" & _
"SELECT * FROM tbl_Holidays WHERE HolidayDate=[prmDate]")
qdf!prmDate = NextBusDay
Set rst = qdf.OpenRecordset(dbOpenSnapshot)
NextBusDayIsHoliday = Not (rst.EOF And rst.BOF)
rst.Close
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
End If
If NextBusDayIsHoliday Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
End Function
I need to read the properties of over 100 tables in an Access 2003 database and write those details - table name, field name, type and size - to a file for further documentation.
I can find nothing from web searches about reading field properties, just field values ...
Can someone please tell me what recordset variables I have to declare (and the syntax) to loop through all of the tables in the DB and extract the field name, type and size from each of them? I will be writing the results to a text file, but I think I can handle that! :)
I'm at a standstill until I can sort this out. It took me a day to document TWO tables manually. Some of the tables have well over 100 fields.
The Database Documenter wizard with these options should give you what you want with the least effort.
If that approach is not satisfactory, you can use custom VBA code to gather the information you want. You can retrieve the names of the tables in your database by looping through the DAO TableDefs collection.
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.name Like "MSys*" Or tdf.name Like "~*") Then
Debug.Print tdf.name
End If
Next
Set tdf = Nothing
Set db = Nothing
To get the field details you want, adapt Allen Browne's TableInfo() function ... substitute file write statements for the Debug.Print statements. Note that function uses 2 helper functions, GetDescrip and FieldTypeName, both of which are included in that linked page.
Here is an Immediate window output sample from TableInfo() for a table in my database --- I think it includes the field information you want.
TableInfo "foo"
FIELD NAME FIELD TYPE SIZE DESCRIPTION
========== ========== ==== ===========
id AutoNumber 4
MyNumber Long Integer 4
MyText Text 255
bar Long Integer 4
========== ========== ==== ===========
After you've adapted the function, call it from the For Each tdf loop in the sample above and feed it each tdf.name:
TableInfo tdf.name
You're going to have to tweak this a bit, it's designed to copy tables from one database to another but it should be a great starting point.
' Database.
Dim dbRep As DAO.Database
Dim dbNew As DAO.Database
' For copying tables and indexes.
Dim tblRep As DAO.TableDef
Dim tblNew As DAO.TableDef
Dim fldRep As DAO.Field
Dim fldNew As DAO.Field
Dim idxRep As DAO.Index
Dim idxNew As DAO.Index
' For copying data.
Dim rstRep As DAO.Recordset
Dim rstNew As DAO.Recordset
Dim rec1 As DAO.Recordset
Dim rec2 As Recordset
Dim intC As Integer
' For copying table relationships.
Dim relRep As DAO.Relation
Dim relNew As DAO.Relation
' For copying queries.
Dim qryRep As DAO.QueryDef
Dim qryNew As DAO.QueryDef
' For copying startup options.
Dim avarSUOpt
Dim strSUOpt As String
Dim varValue
Dim varType
Dim prpRep As DAO.Property
Dim prpNew As DAO.Property
' For importing forms, reports, modules, and macros.
Dim appNew As New Access.Application
Dim doc As DAO.Document
' Open the database, not in exclusive mode.
Set dbRep = OpenDatabase(Forms!CMDB_frmUpgrade.TxtDatabase, False)
' Open the new database
Set dbNew = CurrentDb
DoEvents
' Turn on the hourglass.
DoCmd.Hourglass True
'********************
Debug.Print "Copy Tables"
'********************
If Forms!CMDB_frmUpgrade.CkTables = True Then
Forms!CMDB_frmUpgrade.LstMessages.addItem "Copying Tables:"
' Loop through the collection of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
'***** Table definition
' Create a table definition with the same name.
Set tblNew = dbNew.CreateTableDef(tblRep.Name)
Forms!CMDB_frmUpgrade.LstMessages.addItem "--> " & tblRep.Name & ""
' Set properties.
tblNew.ValidationRule = tblRep.ValidationRule
tblNew.ValidationText = tblRep.ValidationText
' Loop through the collection of fields in the table.
For Each fldRep In tblRep.Fields
' Ignore replication-related fields:
' Gen_XXX, s_ColLineage, s_Generation, s_GUID, s_Lineage
If InStr(1, fldRep.Name, "s_", vbTextCompare) = 0 And _
InStr(1, fldRep.Name, "Gen_", vbTextCompare) = 0 Then
'***** Field definition
Set fldNew = tblNew.CreateField(fldRep.Name, fldRep.Type, _
fldRep.Size)
' Set properties.
On Error Resume Next
fldNew.Attributes = fldRep.Attributes
fldNew.AllowZeroLength = fldRep.AllowZeroLength
fldNew.DefaultValue = fldRep.DefaultValue
fldNew.Required = fldRep.Required
fldNew.Size = fldRep.Size
' Append the field.
tblNew.Fields.Append fldNew
'On Error GoTo Err_NewShell
End If
Next fldRep
'***** Index definition
' Loop through the collection of indexes.
For Each idxRep In tblRep.Indexes
' Ignore replication-related indexes:
' s_Generation, s_GUID
If InStr(1, idxRep.Name, "s_", vbTextCompare) = 0 Then
' Ignore indices set as part of Relation Objects
If Not idxRep.Foreign Then
' Create an index with the same name.
Set idxNew = tblNew.CreateIndex(idxRep.Name)
' Set properties.
idxNew.Clustered = idxRep.Clustered
idxNew.IgnoreNulls = idxRep.IgnoreNulls
idxNew.Primary = idxRep.Primary
idxNew.Required = idxRep.Required
idxNew.Unique = idxRep.Unique
' Loop through the collection of index fields.
For Each fldRep In idxRep.Fields
' Create an index field with the same name.
Set fldNew = idxNew.CreateField(fldRep.Name)
' Set properties.
fldNew.Attributes = fldRep.Attributes
' Append the index field.
idxNew.Fields.Append fldNew
Next fldRep
' Append the index to the table.
tblNew.Indexes.Append idxNew
End If
End If
Next idxRep
' Append the table.
dbNew.TableDefs.Append tblNew
End If
Next tblRep
Following sub will export all table name, field name, type, required , default value to an excel sheet
Sub TableDef()
Dim def As TableDef
Dim wb As Object
Dim xL As Object
Dim lngRow As Long
Dim f As Field
Set xL = CreateObject("Excel.Application")
xL.Visible = True
Set wb = xL.workbooks.Add
lngRow = 2
For Each def In CurrentDb.TableDefs
For Each f In def.Fields
With wb.sheets("Sheet1")
.Range("A" & lngRow).Value = def.Name
.Range("B" & lngRow).Value = f.Name
.Range("C" & lngRow).Value = f.Type
.Range("D" & lngRow).Value = f.Size
.Range("E" & lngRow).Value = f.Required
.Range("F" & lngRow).Value = f.DefaultValue
lngRow = lngRow + 1
End With
Next
Next
End Sub
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