Как скопировать связанную таблицу в локальную таблицу в г-же Access программно?

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