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

[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

 

[Jeff]

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

 

[Jeff]

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