Excel To Access: Transfer multiple rows from excel at the same tim

  • Thread starter Thread starter sam
  • Start date Start date
S

sam

Hi All,

How can I transfer a Bock of data to Access from excel by clicking a "Submit"
button?

eg: I have designed a "Submit" button on the excel sheet that exports all of
the student data into access, but data is populated in a single row...AND I
want to insert all this data in access in seperate rows.

Here is what My excel table looks like:

Student_ID Subjects Grades
123456 Eng A
123456 Hist B
123456 Math B+
123456 Bio B-

So, once we click "Submit" I want the data displayed above to go to access.
NOTE: it should look exactly the same in access as in excel, each row from
excel in a seperate row in access on clicking 'Submit'

What I have now: I can get this data into access but all in one single row,
which looks like this:

Student_ID Subjects Grades Subjects2 Grades2 Subjects3 Grades3
123456 Eng A Hist B Math
B+

What I want:

Student_ID Subjects Grades
123456 Eng A
123456 Hist B
123456 Math B+
123456 Bio B-

So basically It should look the same in access like it looks in excel
(transfer the entire data shown below in access at the same time, each in a
new row).

Hope I made it clear

Thanks in advance
 
Based on your example this works perfectly,


Option Explicit
'Requires reference to ActiveX Data Objects 2.7 Library
'VBE-->Tools-->Reference...-->ActiveX Data Objects 2.7 Library

Public Sub CheckError(ByVal RecordsAffected As Long, _
ByVal Expected As Long, ByVal Description As String)

If RecordsAffected <> Expected Then
Call RaiseError(Description)
End If

End Sub

Public Sub RaiseError(ByVal Description As String)
Call Err.Raise(vbObjectError + 1024, , Description)
End Sub


Public Function GetPrimaryKey(ByVal Command As ADODB.Command) As Long

Dim RecordsAffected As Long
Dim Recordset As ADODB.Recordset

' Retrieve the primary key generated for our new record.
Command.CommandText = "SELECT @@IDENTITY"

Set Recordset = Command.Execute(Options:=CommandTypeEnum.adCmdText)

If Recordset.EOF Then
Call RaiseError("Error retrieving primary key value.")
End If

GetPrimaryKey = Recordset.Fields(0).Value
Recordset.Close

End Function

Public Sub ExecuteCommand(ByVal Command As ADODB.Command, _
ByVal CommandText As String, _
ByVal Description As String)

Dim RecordsAffected As Long
Command.CommandText = CommandText

Call Command.Execute(RecordsAffected, , _
CommandTypeEnum.adCmdText Or ExecuteOptionEnum.adExecuteNoRecords)

Call CheckError(RecordsAffected, 1, Description)

End Sub

Public Sub InsertRecord(ByVal Command As ADODB.Command, _
ByVal acTableName As String, _
ParamArray vArray() As Variant)

Dim CommandText As String
Const Description As String = "Error executing INSERT statement."

' May require some editing on your part
CommandText = "INSERT INTO " & acTableName & "(Student_Id, Subjects,
Grades) " & _
"VALUES('" & vArray(0) & "','" & vArray(1) & "','" & vArray(2) & "')"


Call ExecuteCommand(Command, CommandText, Description)

End Sub

Private Property Get ConnectionString() As String
' Use Connection.udl to create connection string
' open with notepad to copy/paste
ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and
Settings\Z200825\Desktop\New_Dev.mdb;" & _
"Mode=ReadWrite;Persist Security Info=False"

End Property


Public Sub StartRecord()
Dim Command As ADODB.Command
Dim Key As Long
Dim Ws As Worksheet
Dim LastRow As Long
Dim I As Long

On Error GoTo ErrorHandler

Set Command = New ADODB.Command
Command.ActiveConnection = ConnectionString

' Change to suit
Set Ws = Worksheets(1)

'Finds the lastrow form the bottom up
LastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

' loop through range adding one record @ a time.
For I = 2 To LastRow

Key = GetPrimaryKey(Command)

' This may also require some editiing
Call InsertRecord(Command, "tbl_test", _
Ws.Cells(I, 1), _
Ws.Cells(I, 2), _
Ws.Cells(I, 3))

Next
ErrorExit:
Set Command = Nothing
Exit Sub

ErrorHandler:
Call MsgBox(Err.Description, vbCritical)
Resume ErrorExit
End Sub
 
If you're unfamiliar with connection.udl run the below code it will drop one
on your desktop.

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA"
( _
ByVal lpBuffer As String, _
ByRef nSize As Long) As Long

Sub CreateConnectionUDL()
Dim oFSO As Object

Set oFSO = CreateObject("Scripting.FileSystemObject")

oFSO.CreateTextFile ("C:\Documents and Settings\" & UserName &
"\Desktop\Connection.udl")

Set oFSO = Nothing
End Sub

Private Function UserName() As String
Dim Buffer As String * 255
Dim Length As Long
Dim Result As Long

Length = 255

Result = GetUserName(Buffer, Length)

If Length > 0 Then UserName = Left(Buffer, Length - 1)
End Function
 
Back
Top