Access VBA Create Table
by admin on Friday, August 23rd, 2013 | No Comments
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