Need Help with VBA to create a New Table

[calihiker]

I have a form which contains a list of tables in a combo box, the user clicks on a table name and then clicks on the command button (that opens that particular table)...Here's where I am stuck. I need to create code that takes all the records selected by the user and create a seperate "new" table. Is this possible? What I would like is to enable the user to press a button after they select a group or multiple groups of rows in the table and be able to create a table from scratch. Any help would be appreciated, thanks!

 

[bradmaunsell]

Here are a group of routines I wrote. I use these to create a separate data entry batch table named by user name.


'******************************************************************************************************************************************************
'This code is in my data entry form

'TABLE SETUP

Private Sub Form_Load()

SetupBatchTable_Hdr
Me.RecordSource = "DE_Hdr_" & GetNetworkUserName

SetupBatchTable_Sub
Forms!frmDE_Hdr![frmDE_Sub].Form.RecordSource = "DE_Sub_" & GetNetworkUserName

Me.GL_Tr_Numb = NextTrxNumber
Me.AP_HDR_ID = NextAP()
DoCmd.GoToControl "GL_Jrn"
End Sub

'******************************************************************************************************************************************************

'This code is in a separate module

Option Compare Database
Option Explicit
' 5/16/2003 Brad Maunsell

Function GetDataEntryBatch(HS As String) As String

Dim dbs As Database
Dim i
Dim HdrSub As String

If HS = "H" Then
HdrSub = "DE_Hdr_"
Else
HdrSub = "DE_Sub_"
End If

Set dbs = CurrentDb()
With dbs
For Each i In .TableDefs 'Look thru tabledef collection for existing tables for this user
If i.Name = HdrSub & GetNetworkUserName Then
GetDataEntryBatch = i.Name
'a = "Batch table named " & i.Name & " already exists. " & Chr(13) & "It was created " & i.DateCreated & Chr(13) & " and last updated on " & i.LastUpdated
End If
Next i
End With
dbs.Close
Set dbs = Nothing
End Function



Sub CreateDataEntryBatch(HS As String)
Dim dbs As Database, tdf As TableDef, fld As Field
Dim HdrSub As String

If HS = "H" Then
HdrSub = "DE_Hdr_"
Else
HdrSub = "DE_Sub_"
End If

Set dbs = CurrentDb


Set tdf = dbs.CreateTableDef(HdrSub & GetNetworkUserName) ' Return TableDef object variable that points to new table.


Set fld = tdf.CreateField("GL_Tr_Numb", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("AP_HDR_ID", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_Jrn", dbText, 8) ' Define new field in table.
tdf.Fields.Append fld ' Append Field object to Fields collection of TableDef object.
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_Vendor_ID", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_Program", dbText, 6)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_TrxDate", dbDate)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_AP_DueDate", dbDate)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_DocNumber", dbText, 20)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_ChartID", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_Memo", dbMemo)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_DR", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_CR", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_ClaimNumber", dbDouble)
tdf.Fields.Append fld
tdf.Fields.Refresh

Set fld = tdf.CreateField("GL_ClaimExpIndDep", dbText, 1)
tdf.Fields.Append fld
tdf.Fields.Refresh

dbs.TableDefs.Append tdf ' Append TableDef object to TableDefs collection of database.

dbs.TableDefs.Refresh
Set dbs = Nothing
End Sub

Sub DropDataEntryBatch(HS)
Dim dbs As Database
Dim HdrSub As String

If HS = "H" Then
HdrSub = "DE_Hdr_"
Else
HdrSub = "DE_Sub_"
End If

Set dbs = CurrentDb()
'On Error Resume Next
' Delete the tmp table.
dbs.Execute "DROP TABLE " & HdrSub & GetNetworkUserName

dbs.Close
Exit Sub
NotExist:
dbs.Close

End Sub

Sub SetupBatchTable_Hdr()
Dim strSQL As String
Dim strBatch As String
Dim HS As String

HS = "H"
On Error Resume Next
strBatch = GetDataEntryBatch(HS)

If strBatch = "DE_Hdr_" & GetNetworkUserName Then
ClearBatchTable (HS)
Else
CreateDataEntryBatch (HS)
End If
End Sub

Sub SetupBatchTable_Sub()
Dim strSQL As String
Dim strBatch As String
Dim HS As String

HS = "S"
On Error Resume Next
strBatch = GetDataEntryBatch(HS)

If strBatch = "DE_Sub_" & GetNetworkUserName Then
ClearBatchTable (HS)
Else
CreateDataEntryBatch (HS)
End If
End Sub

Sub ClearBatchTable(HS)
Dim strSQL As String
Dim HdrSub As String

If HS = "H" Then
HdrSub = "DE_Hdr_"
Else
HdrSub = "DE_Sub_"
End If

strSQL = "DELETE * FROM " & HdrSub & GetNetworkUserName
DoCmd.RunSQL (strSQL)
End Sub