Slicemahn
04-29-2008, 03:06 AM
Hello VBAX Nation!
I have can really use a second set of eyes for some code I am trying to finish. For some reason I keep getting a Run-Time Error Application or object defined error.
Here is what I am trying to do: I have a sheet that will holds the names of workbooks in column M starting at the third row. I have a loop that will
(1) open each workbook (2)open database connection (3)write the values contained in the workbook to the applicable database table (4)close the workbook (5)Loop to next workbook until no more remaining (6) close the database connection.
Here is my code:
Public Sub KanaDoIT()
Dim conn As ADODB.Connection
Dim Rcdst As ADODB.Recordset
Dim CurRow As Integer
Dim temp As FileSystemObject
Dim fold As Folder
Dim file1 As File
Dim wb, wbtemp As Workbook
Dim ws, wstemp As Worksheet
Dim path1 As String
Dim j As Integer
Dim DataTable As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=S:\REPORTS\1_Daily\CANADA\cANADA 9.5.mdb;"
Set Rcdst = New ADODB.Recordset
'Assign Variables
Set wb = ActiveWorkbook
Set ws = wb.Worksheets(1)
date1 = ws.Range("day1")
'Set folder and file paths
Set temp = New FileSystemObject
path1 = ws.Range("path")
Set fold = temp.GetFolder(path1)
j = 3
Do Until ws.Cells(j, 13) = ""
date1 = ws.Range("day1")
DataTable = Cells(j, 13).Value
If ws.Cells(j, 14) = "Y" Then
Set wbtemp = Workbooks.Open(path1 & "\" & ws.Cells(j, 13))
Set wstemp = wbtemp.Worksheets(1)
Rcdst.Open DataTable, conn, adOpenKeyset, adLockOptimistic, adCmdTable
CurRow = 2
Do While Len(wstemp.Range("A" & CurRow).Formula) > 0 'Otherwise do as long as there is something in column A
With Rcdst
.AddNew
.Fields("Queue") = wstemp.Range("A" & CurRow).Value
.Fields("Date") = wstemp.Range("B" & CurRow).Value
.Fields("Number of Message Complete") = wstemp.Range("C" & CurRow).Value
.Fields("Number of Response") = wstemp.Range("D" & CurRow).Value
.Fields("Avg Processing Time") = wstemp.Range("E" & CurRow).Value
.Fields("Avg Restonse Time") = wstemp.Range("F" & CurRow).Value
.Fields("Within SVL Response") = wstemp.Range("G" & CurRow).Value
.Fields("SVL") = Round(wstemp.Range("H" & CurRow), 5)
.Fields("Active Message Queue") = wstemp.Range("I" & CurRow).Value
.Fields("Message Entering Queue") = wstemp.Range("J" & CurRow).Value
.Fields("Message Leaving Queue") = wstemp.Range("K" & CurRow).Value
.Update
End With
CurRow = CurRow + 1
Loop
Rcdst.Close
ThisWorkbook.Worksheets(1).Range(Cells(j, 16)) = "Done!"
wbtemp.Close (True)
End If
j = j + 1
Loop
conn.Close
Set conn = Nothing
MsgBox "All tables have been updated in the CANADA database", vbOKOnly, "Reporting"
End Sub
Apparently the error occurs at
ThisWorkbook.Worksheets(1).Range(Cells(j, 16)) = "Done!"
I appreciate all your suggestions and help on this.
CCSlice
I have can really use a second set of eyes for some code I am trying to finish. For some reason I keep getting a Run-Time Error Application or object defined error.
Here is what I am trying to do: I have a sheet that will holds the names of workbooks in column M starting at the third row. I have a loop that will
(1) open each workbook (2)open database connection (3)write the values contained in the workbook to the applicable database table (4)close the workbook (5)Loop to next workbook until no more remaining (6) close the database connection.
Here is my code:
Public Sub KanaDoIT()
Dim conn As ADODB.Connection
Dim Rcdst As ADODB.Recordset
Dim CurRow As Integer
Dim temp As FileSystemObject
Dim fold As Folder
Dim file1 As File
Dim wb, wbtemp As Workbook
Dim ws, wstemp As Worksheet
Dim path1 As String
Dim j As Integer
Dim DataTable As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=S:\REPORTS\1_Daily\CANADA\cANADA 9.5.mdb;"
Set Rcdst = New ADODB.Recordset
'Assign Variables
Set wb = ActiveWorkbook
Set ws = wb.Worksheets(1)
date1 = ws.Range("day1")
'Set folder and file paths
Set temp = New FileSystemObject
path1 = ws.Range("path")
Set fold = temp.GetFolder(path1)
j = 3
Do Until ws.Cells(j, 13) = ""
date1 = ws.Range("day1")
DataTable = Cells(j, 13).Value
If ws.Cells(j, 14) = "Y" Then
Set wbtemp = Workbooks.Open(path1 & "\" & ws.Cells(j, 13))
Set wstemp = wbtemp.Worksheets(1)
Rcdst.Open DataTable, conn, adOpenKeyset, adLockOptimistic, adCmdTable
CurRow = 2
Do While Len(wstemp.Range("A" & CurRow).Formula) > 0 'Otherwise do as long as there is something in column A
With Rcdst
.AddNew
.Fields("Queue") = wstemp.Range("A" & CurRow).Value
.Fields("Date") = wstemp.Range("B" & CurRow).Value
.Fields("Number of Message Complete") = wstemp.Range("C" & CurRow).Value
.Fields("Number of Response") = wstemp.Range("D" & CurRow).Value
.Fields("Avg Processing Time") = wstemp.Range("E" & CurRow).Value
.Fields("Avg Restonse Time") = wstemp.Range("F" & CurRow).Value
.Fields("Within SVL Response") = wstemp.Range("G" & CurRow).Value
.Fields("SVL") = Round(wstemp.Range("H" & CurRow), 5)
.Fields("Active Message Queue") = wstemp.Range("I" & CurRow).Value
.Fields("Message Entering Queue") = wstemp.Range("J" & CurRow).Value
.Fields("Message Leaving Queue") = wstemp.Range("K" & CurRow).Value
.Update
End With
CurRow = CurRow + 1
Loop
Rcdst.Close
ThisWorkbook.Worksheets(1).Range(Cells(j, 16)) = "Done!"
wbtemp.Close (True)
End If
j = j + 1
Loop
conn.Close
Set conn = Nothing
MsgBox "All tables have been updated in the CANADA database", vbOKOnly, "Reporting"
End Sub
Apparently the error occurs at
ThisWorkbook.Worksheets(1).Range(Cells(j, 16)) = "Done!"
I appreciate all your suggestions and help on this.
CCSlice