ExcelBanter - Excel to Access and Access to Excel

On Jun 14, 11:58 am, reachkars wrote:
On Jun 11, 5:59 pm, "Michael Kintner" wrote:

I am trying to use Excel as the input area and then post the data into
Access. I have seperate fields in tables as well as sheets of data entry.

Mike

"reachkars" wrote in message

roups.com...

On Jun 11, 3:09 pm, "Michael Kintner" wrote:
Does anybody have any examples for keying data into excel and have it
update
an Microsoft Access database on the fly?

Thank you in advance for any help,
Michael Kintner

Are you trying to enter data in a excel spreadsheet & transfer the
same to a access table & then then fetch it from the access table &
populate the excel sheet??- Hide quoted text -

- Show quoted text -

'Below is my code which is part of an application i had deevloped.
This code, connects to a Access database, sorts the contents of the
excel sheet, & transfers the data to a table in the Access database. &
then fetches the data from the access table & populates the excel
sheet. This code also handles the cell with Formulas.
'You might use the entire code or any part of the code below as per
your requirement.
'For any further clarification contact me at

Public Function Databaseconnect()

' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=[Database
path];Jet OLEDB:System Database=[Workgroup file if available];"

End Function

Public Function Recordsetopen()

' open a recordset
Set rs = New ADODB.Recordset
rs.Open "[Table Name]", cn, adOpenKeyset, adLockOptimistic,
adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet

End Function

'The below function is to sort the data in the excel sheet in the
ascending order.

Public Function SortSheet()

ThisWorkbook.Worksheets("[Current work sheet]").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
End Function

'Sample Target Range = Range("A1")
Public Function TransferToAccessTable(TargetRange1 As Range)

s = 1

Set TargetRange1 = TargetRange1.Cells(1, 1)

SortSheet

ColCount = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column

Do While Len(Range("A" & r).Formula) 0

' repeat until first empty cell in column A

With rs
.AddNew ' create a new record

' add values to each field in the record

For i = 0 To (ColCount - 1)
'temp = svar(i)
.Fields(i) = GETFORMULA(TargetRange1.Offset((r - 1),
i))
'Debug.Print i
Next i

.Update ' stores the new record
End With
'Debug.Print r
r = r + 1 ' next row
DoEvents

Loop

rs.Close

End Function

Public Function TransferFromAccessTable(TargetRange As Range)

Dim TableName As String
Dim objCommand As ADODB.Command
Dim intColIndex As Integer
Dim PrevRow, CurrRow As Integer
Dim strPrevRow, strCurrRow As Integer

Set objCommand = New ADODB.Command

TableName = "[Table Name]"

Set TargetRange = TargetRange.Cells(1, 1)
Set rs = New ADODB.Recordset

'Get the newly populated data
Set objCommand = New ADODB.Command

With objCommand
.ActiveConnection = cn
.CommandType = adCmdText
.CommandText = "Select * from [Table Name];"
Set rs = .Execute()
End With

DoEvents
With rs
' open the recordset

For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
TargetRange.Offset(0, intColIndex).Value =
rs.Fields(intColIndex).Name
Debug.Print intColIndex
Next

TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset
data

End With

SortSheet

Dim ii, jj, strTmp
ii = 1
jj = 0
strTmp = ""

ThisWorkbook.Worksheets("[Work sheet where data should be
entered]").Select
'Get the total number of rows with data populated
RowCount = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
'Get the total number of Columns with data populated
ColCount = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column

'The below code is to ensure that the formulas are handled
properly...

Do While Len(Range("A" & ii).Formula) 0 'repeat until the 1st
empty cell in Column A

PrevRow = (TargetRange.Offset(ii, ColCount - 2).Value + 1)
CurrRow = (TargetRange.Offset(ii, ColCount - 1).Value + 1)
strPrevRow = CStr(PrevRow)
strCurrRow = CStr(CurrRow)

For jj = 0 To ColCount - 1
If Not IsEmpty(TargetRange.Offset(ii, jj).Value) Then
If Not IsNull(TargetRange.Offset(ii, jj).Value) Then
If Left(TargetRange.Offset(ii, jj).Value, 1) = "="
Then
If PrevRow < CurrRow Then
strTmp = TargetRange.Offset(ii, jj).Value
strTmp = FindReplace(strTmp, strPrevRow,
strCurrRow)
TargetRange.Offset(ii, jj).Formula =
strTmp
Else
TargetRange.Offset(ii, jj).Formula =
TargetRange.Offset(ii, jj).Value
End If
End If
End If
End If
Next
ii = ii + 1
DoEvents
Loop

End Function- Hide quoted text -

- Show quoted text -

Kindly include this function as well.. this is to ensure tht, for
those cells having formulas behind, the formula is transfered instead
of the data... u may omit this if your dont need this functionality.

Function GETFORMULA(CELL As Range) As String

If CELL.HasFormula Then
GETFORMULA = CELL.Formula
Else
If CELL.Value < "" Then
GETFORMULA = CELL.Value
Else
GETFORMULA = " "
End If
End If

End Function

Regards,
Karthik