Public Function CopyTable()
Dim db As Database
Dim rsto As Recordset
Dim rstn As Recordset
Dim stroTable As String
Dim strnTable As String
Dim RecCount As Long
Dim varBookmark As Variant
On Error GoTo ErrHandler
[COLOR=green]'Get the name of the table[/color]
stroTable = InputBox("Enter in the old table: ", "Old Table...")
[COLOR=green]'Get the name of the new table[color]
strnTable = InputBox("Enter in the new table: ", "New Table...")
If fExistTable("" & strnTable & "") = False Then [COLOR=green]'Check for table existance[/color]
[COLOR=green]'If table does not exist, create one using the same structure as the table you want to copy[/color]
sCopyTableStructure "" & stroTable & "", "" & strnTable & ""
End If
[COLOR=green]'Open the tables recordset[/color]
Set db = CurrentDb()
Set rsto = db.OpenRecordset("" & stroTable & "")
Set rstn = db.OpenRecordset("" & strnTable & "")
RecCount = 0
rsto.MoveLast
rsto.MoveFirst
Do While Not rsto.EOF
varBookmark = rsto.Bookmark
rstn.AddNew
[COLOR=green]'Copy Data for each field to the table[/color]
For RecCount = 0 To rstn.Fields.Count - 1
rstn.Fields(RecCount).Value = rsto.Fields(rstn.Fields(RecCount).Name).Value
Next
[COLOR=green]'Continue copying all rows from old table to new table[/color]
rstn.Update
RecCount = RecCount + 1
DoEvents
If RecCount Mod 10 = 0 Then
MsgBox RecCount [COLOR=green]'Show progress every 10 rows[/color]
End If
If RecCount = 50 Then
Exit Function
End If
rsto.MoveNext
Loop
MsgBox RecCount [COLOR=green]'Show total successful record count[/color]
rsto.Close
rstn.Close
db.Close
ExitLine:
Exit Function
ErrHandler:
MsgBox "Error: " & Error$
Resume ExitLine
End Function
[COLOR=green]'---------------------------------------------------------------------------------------[/color]
Public Function sCopyTableStructure(strOldTableName As String, strNewTableName As String)
If vbYes = MsgBox("Are you sure?", vbYesNo + vbDefaultButton2 + vbExclamation, "Create New Table ") Then
DoCmd.TransferDatabase acImport, "Microsoft Access", CurrentDb.Name, acTable, strOldTableName, strNewTableName, True
End If
End Function
[COLOR=green]'---------------------------------------------------------------------------------------[/color]
Public Function fExistTable(strTableName As String) As Integer
Dim db As Database
Dim i As Integer
Set db = DBEngine.Workspaces(0).Databases(0)
fExistTable = False
db.TableDefs.Refresh
For i = 0 To db.TableDefs.Count - 1
If strTableName = db.TableDefs(i).Name Then
'Table Exists
fExistTable = True
Exit For
End If
Next i
Set db = Nothing
End Function