T
TIML
I am trying to populate an Access table with Excel data. I am using Office
2000.
The following code, running in my excel workbook, works off and on but is
not consistent. Any thoughts would be greatly appreaciated.
Dim db As Database, rs As Recordset, RFound As Boolean, JVar As Variant,
DVar As Variant, MyFile, MyDate As Date
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Set db =
OpenDatabase("\\GEORGE\Public\Databases\Production\Secure\Production.mdb")
' open the database
Set rs = db.OpenRecordset("ProductionbySC", dbOpenTable)
' get all records in a table
JVar = Range("B3").Value
DVar = Range("B2").Value
If JVar = "" Then
MsgBox "There is no Julian Date, Please enter the Julian Date", vbOKOnly
Cancel = True
Exit Sub
End If
If DVar = "" Then
MsgBox "There is no Date, Please enter the Date", vbOKOnly
Cancel = True
Exit Sub
End If
' Clear out Detail Page
Sheets("Details").Select
Range("A2:M2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
' Copy to Detail Sheet
Sheets("Main").Select
Range("C6:O33").Select
Selection.Copy
Sheets("Details").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Range("A2").Select
i = 0
Do
i = i + 1
If ActiveCell.Value = "" Then
Selection.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop Until i = 29
Range("A1").Select
ActiveWorkbook.Names("Detail").Delete
Range("A1:M1").Select
Range(Selection, Selection.End(xlDown)).Name = "Detail"
MyFile = ActiveWorkbook.FullName
MyDate = Sheets("Main").Range("B2")
Sql = "DELETE * FROM ProductionbySC WHERE Date = " & MyDate '''''''
Doesn't Work
DoCmd.RunSQL (Sql) ''''''' Doesn't Work
DoCmd.TransferSpreadsheet acImport, 5, "ProductionbySC", MyFile, True,
"Detail" ''''''' Doesn't Work all the time
rs.Close
Set rs = Nothing
db.Close
2000.
The following code, running in my excel workbook, works off and on but is
not consistent. Any thoughts would be greatly appreaciated.
Dim db As Database, rs As Recordset, RFound As Boolean, JVar As Variant,
DVar As Variant, MyFile, MyDate As Date
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Set db =
OpenDatabase("\\GEORGE\Public\Databases\Production\Secure\Production.mdb")
' open the database
Set rs = db.OpenRecordset("ProductionbySC", dbOpenTable)
' get all records in a table
JVar = Range("B3").Value
DVar = Range("B2").Value
If JVar = "" Then
MsgBox "There is no Julian Date, Please enter the Julian Date", vbOKOnly
Cancel = True
Exit Sub
End If
If DVar = "" Then
MsgBox "There is no Date, Please enter the Date", vbOKOnly
Cancel = True
Exit Sub
End If
' Clear out Detail Page
Sheets("Details").Select
Range("A2:M2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
' Copy to Detail Sheet
Sheets("Main").Select
Range("C6:O33").Select
Selection.Copy
Sheets("Details").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Range("A2").Select
i = 0
Do
i = i + 1
If ActiveCell.Value = "" Then
Selection.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop Until i = 29
Range("A1").Select
ActiveWorkbook.Names("Detail").Delete
Range("A1:M1").Select
Range(Selection, Selection.End(xlDown)).Name = "Detail"
MyFile = ActiveWorkbook.FullName
MyDate = Sheets("Main").Range("B2")
Sql = "DELETE * FROM ProductionbySC WHERE Date = " & MyDate '''''''
Doesn't Work
DoCmd.RunSQL (Sql) ''''''' Doesn't Work
DoCmd.TransferSpreadsheet acImport, 5, "ProductionbySC", MyFile, True,
"Detail" ''''''' Doesn't Work all the time
rs.Close
Set rs = Nothing
db.Close