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.
'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 (e-mail address removed)
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 -