Access VBA Create Table

This example is a response from an email I received regarding:

“How to build a table by extracting some fields from a main database…”

I interpret it as: “Query a main database (mainframe) and create a local table.”

I do have another easier version of this process at “How To Create A Table In Access Using SQL And VBA”

Take a look, and get the example database below:

Option Compare Database
'========================================================
'DATABASE DESIGNED & CODED BY LOEBLCOM SERVICES 2013
'ERIK LOEBL(713)409-7041
'EMAIL: erik@loeblcomservices.com
'WEB: http://loeblcomservices.com
'========================================================

Private Sub btnCreateTable_Click()

	'OBJECTIVE: to build a table by extracting some fields from a main database

	Dim rst As Recordset
	Dim strSQL As String
	Dim intCount As Integer
	Dim intNumFields As Integer

	Dim i As Integer
	Dim strRecords() As String
	Dim strFields As String

	Dim intStatus As Integer

	'A query to a "main frame computer"
	strSQL = "SELECT DISTINCT [Last Name],[First Name],Address,City,[State/Province] FROM Customers "

	Set rst = CurrentDb.OpenRecordset(strSQL)

	'LOAD ARRAY FOR FIELD NAMES FROM THE RST

	'FIND THE # OF RECORDS IN THIS SET...
	rst.MoveLast
	rst.MoveFirst

	'Total number of records in this recordset
	intCount = rst.RecordCount - 1 '0-based
	i = 0

	intNumFields = rst.Fields.Count

	'strFields = rst.Fields(0).Name 'for 1 field name
	strFields = rst.Fields(0).Name & "," & rst.Fields(1).Name & "," & rst.Fields(2).Name & "," & rst.Fields(3).Name & "," & rst.Fields(4).Name

	Do Until rst.EOF

		'Store the values of the query in an array...
		ReDim Preserve strRecords(i)

		'strRecords(i) = rst.Fields(0) 'for 1 field
		strRecords(i) = rst.Fields(0) & "," & rst.Fields(1) & "," & rst.Fields(2) & "," & rst.Fields(3) & "," & rst.Fields(4)

		'Debug.Print strRecords(i)

		i = i + 1
		rst.MoveNext
	Loop

	rst.Close
	Set rst = Nothing

	'BUILD A CUSTOM TABLE BASED ON THE FIELD NAMES IN THE ARRAY...

	intStatus = CreateTable(strFields, strRecords(), intNumFields, Me.txtNewTableName)

	If intStatus = True Then

		MsgBox "Table created and data entered successfully"

	End If

End Sub


Public Function CreateTable(table_fields As String, table_data As Variant, num_fields As Integer, table_name As String) As Boolean
	Dim strCreateTable As String

	Dim intCount As Integer

	Dim strFields() As String
	Dim strValues() As String

	Dim strInsertSQL As String

	Dim intCounter As Integer
	Dim intData As Integer

	On Error GoTo errHandler

	'split the string on the comma delimiter
	strFields = Split(table_fields, ",")

	If TableExists(table_name) Then
		'DROP THE TABLE IF IT EXISTS.
		CurrentDb.Execute "DROP TABLE " & table_name
	End If

	'this creates the table structure...
	strCreateTable = "CREATE TABLE " & table_name & "("

	For intCounter = 0 To num_fields - 1
		strCreateTable = strCreateTable & "[" & strFields(intCounter) & "] varchar(150),"
	Next

	If Right(strCreateTable, 1) = "," Then
		strCreateTable = Left(strCreateTable, Len(strCreateTable) - 1)
		strCreateTable = strCreateTable & ")"
	End If

	CurrentDb.Execute strCreateTable

	intCounter = 0 'reset
	intData = 0 'reset

	If Err.Number = 0 Then

		For intData = 0 To UBound(table_data)

			'split the row on the comma delimiter
			strValues = Split(table_data(intData), ",")

			'=======================================================================
			'now insert the values into the new table
			'=======================================================================
			strInsertSQL = "INSERT INTO " & table_name & "("

			For intCounter = 0 To num_fields - 1
				strInsertSQL = strInsertSQL & "[" & strFields(intCounter) & "],"
			Next

			If Right(strInsertSQL, 1) = "," Then
				strInsertSQL = Left(strInsertSQL, Len(strInsertSQL) - 1)
				strInsertSQL = strInsertSQL & ")"
			End If

			'==================================================
			'now enter the values...
			'==================================================
			strInsertSQL = strInsertSQL & " VALUES ("

			intCounter = 0

			For intCounter = 0 To num_fields - 1
				strInsertSQL = strInsertSQL & """" & strValues(intCounter) & ""","

			Next

			If Right(strInsertSQL, 1) = "," Then
				strInsertSQL = Left(strInsertSQL, Len(strInsertSQL) - 1)
				strInsertSQL = strInsertSQL & ")"
			End If

			'==================================================
			'insert data row... '==================================================
			Debug.Print strInsertSQL
			CurrentDb.Execute strInsertSQL

		Next 'next data row

		CreateTable = True
	End If

	Exit Function
	errHandler:
		CreateTable = False
		MsgBox Err.Number & " " & Err.Description

End Function

Public Function DropTable(strTableName) As Boolean
	Dim db As Object
	Dim td As Object

	Set db = CreateObject("DAO.DBEngine.36")
	Set db = CurrentDb

	'Find the table
	Set td = db.TableDefs(strTableName)

	'Drop the table
	CurrentProject.Connection.Execute "DROP TABLE [" & strTableName & "]"

	Set td = Nothing
	Set db = Nothing

	DropTable = True

End Function

Public Function TableExists(strTable As String) As Boolean
	Dim rst As Recordset
	Dim strSQL As String

	On Error GoTo errHandler

	'FOR SQL Server
	'strsql = "SELECT name FROM Msysobjects WHERE type='u' AND Name='Transformers'" for projects

	'FOR Access
	strSQL = "SELECT MSysObjects.Name FROM MSysObjects WHERE MSysObjects.Name='" & strTable & "'"

	Set rst = CurrentDb.OpenRecordset(strSQL)

	If Not rst.EOF Then
		TableExists = True
	Else
		TableExists = False
	End If

	rst.Close
	Set rst = Nothing

	Exit Function

	errHandler:
		TableExists = False
		MsgBox Err.Number & " " & Err.Description

End Function

Click here for the database and the code:
access-vba-create-table.mdb

By the way, if you got or are getting value from the VBA information, please click the "Donate" button to give me a small token of your appreciation, thanks!