Hi All,

I am in need of immediate help Please.

I wrote a excel vba script to extratc the data from excel into the
MSAccess DB.
The script extracts only the first row of the spreadsheet into the
access database and it correctly loops for the rest of the rows in the
excel and gets the value correctly but does not update my database.

Below is the code
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~
Sub check()
Dim lcount As Long
Dim wbresults As Workbook
Dim wbcodebook As Workbook
Dim ws As Worksheet
Dim wbname As String
Dim j As Integer
Dim received1 As String
Dim txt As String
Dim x As Variant
Dim xcom As Worksheet
Dim k As Integer
k = 2
j = 0

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
Set wbcodebook = ThisWorkbook
With Application.FileSearch
.NewSearch
.LookIn = "D:\HR\Email Attachments"
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
If .Execute 0 Then 'workbooks in folder
For lcount = 1 To .FoundFiles.Count 'Loop through all files

'open workbook x and set a workbook variable to it
Set wbresults = Workbooks.Open(.FoundFiles(lcount))
j = j + 1 'variable to get the count of number of
emails received.
txt = wbresults.name
x = Split(txt, "_")
wbname = x(0)


received1 = received1 + vbCrLf + wbname
MsgBox received1
Set xcom = ActiveSheet
xcom.Range("B1") = "Responses"
xcom.Range("B" & k) = wbname
k = k + 1

'code start for worksheet here
'For Each ws In wbresults.Worksheets

'code to insert each worksheet into Access database
Dim act As Worksheet
Dim rowsc As Integer
Set act = wbresults.Sheets("Memberships").Select

'exports data from the active worksheet to a table in
an Access database

Dim cn As ADODB.Connection, rs As ADODB.Recordset, r
As Long
'connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=D:\Skills.mdb;"
'open a recordset
Set rs = New ADODB.Recordset
rs.Open "Memberships", cn, adOpenKeyset,
adLockOptimistic, adCmdTable
' all records in a table
For r = 8 To 18
With rs
If (Range("D" & r).Value "") Then
.AddNew ' create a new record
.Fields("Email") = wbname
.Fields("Membership_Name") = Range("B" &
r).Value
.Fields("Member") = Range("D" & r).Value
.Fields("Member_Since") = Range("E" &
r).Value
.Update ' stores the new record1
End If
End With
Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Set act = Nothing
ActiveWorkbook.Close
wbresults.Close savechanges:=True
Next
End If

End With
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~
Only for the first row (D8) i am able to see the value when i place the
cursor at .value and after execution at .Fields but from the 2nd row
(D9)onwards i can see the value when cursor placed at .value but i cant
see anything when i place the curson at .fields while debugging.

Please help me to solve this problem.
I am sure my thread is not alligned but i am not sure of including the
attachment, apologies for this and

Thanks in advance




*** Sent via Developersdex http://www.developersdex.com ***

Am Mon, 20 Mar 2006 09:30:45 -0800 schrieb sug sri:

If you comment out the On Error statement, do you get an errror?

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --


Hi All,

I am in need of immediate help Please.

I wrote a excel vba script to extratc the data from excel into the
MSAccess DB.
The script extracts only the first row of the spreadsheet into the
access database and it correctly loops for the rest of the rows in the
excel and gets the value correctly but does not update my database.

Below is the code
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~
Sub check()
Dim lcount As Long
Dim wbresults As Workbook
Dim wbcodebook As Workbook
Dim ws As Worksheet
Dim wbname As String
Dim j As Integer
Dim received1 As String
Dim txt As String
Dim x As Variant
Dim xcom As Worksheet
Dim k As Integer
k = 2
j = 0

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
Set wbcodebook = ThisWorkbook
With Application.FileSearch
.NewSearch
.LookIn = "D:\HR\Email Attachments"
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
If .Execute 0 Then 'workbooks in folder
For lcount = 1 To .FoundFiles.Count 'Loop through all files

'open workbook x and set a workbook variable to it
Set wbresults = Workbooks.Open(.FoundFiles(lcount))
j = j + 1 'variable to get the count of number of
emails received.
txt = wbresults.name
x = Split(txt, "_")
wbname = x(0)


received1 = received1 + vbCrLf + wbname
MsgBox received1
Set xcom = ActiveSheet
xcom.Range("B1") = "Responses"
xcom.Range("B" & k) = wbname
k = k + 1

'code start for worksheet here
'For Each ws In wbresults.Worksheets

'code to insert each worksheet into Access database
Dim act As Worksheet
Dim rowsc As Integer
Set act = wbresults.Sheets("Memberships").Select

'exports data from the active worksheet to a table in
an Access database

Dim cn As ADODB.Connection, rs As ADODB.Recordset, r
As Long
'connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=D:\Skills.mdb;"
'open a recordset
Set rs = New ADODB.Recordset
rs.Open "Memberships", cn, adOpenKeyset,
adLockOptimistic, adCmdTable
' all records in a table
For r = 8 To 18
With rs
If (Range("D" & r).Value "") Then
.AddNew ' create a new record
.Fields("Email") = wbname
.Fields("Membership_Name") = Range("B" &
r).Value
.Fields("Member") = Range("D" & r).Value
.Fields("Member_Since") = Range("E" &
r).Value
.Update ' stores the new record1
End If
End With
Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Set act = Nothing
ActiveWorkbook.Close
wbresults.Close savechanges:=True
Next
End If

End With
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~
Only for the first row (D8) i am able to see the value when i place the
cursor at .value and after execution at .Fields but from the 2nd row
(D9)onwards i can see the value when cursor placed at .value but i cant
see anything when i place the curson at .fields while debugging.

Please help me to solve this problem.
I am sure my thread is not alligned but i am not sure of including the
attachment, apologies for this and

Thanks in advance




*** Sent via Developersdex http://www.developersdex.com ***