cheekybuddha
AWF VIP
- Local time
- Today, 19:26
- Joined
- Jul 21, 2014
- Messages
- 2,829
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim lngRowsAffected As Long
Dim lngRowsDeleted As Long
Dim fileName As Variant
Dim fsname As Variant
Dim xlApp As Excel.Application
Set db = CurrentDb
fileName = Dir("\\Svrfiles\access databases\Portfolio Test\")
Do While fileName <> ""
DoCmd.OpenQuery "QryDeleteCash", acViewNormal
DoCmd.TransferSpreadsheet acLink, , "TblInputSht", "\\Svrfiles\access databases\Portfolio Test\" & fileName, False, "Input Sheet!D6:E32"
DoCmd.TransferSpreadsheet acLink, , "TblInputShtName", "\\Svrfiles\access databases\Portfolio Test\" & fileName, False, "Input Sheet!E3:E3"
Set qdf = db.QueryDefs("QryImport2")
db.Execute "QryImport2", dbFailOnError
For Each prm In qdf.Parameters
prm = Eval(prm.Name)
Next prm
qdf.Execute
lngRowsAffected = db.RecordsAffected
DoCmd.DeleteObject acTable, "TblInputShtName"
DoCmd.DeleteObject acTable, "TblInputSht"
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open "\\Svrfiles\ACCESS DATABASES\cashrptgraph.xlsm", True, False
xlApp.ActiveWorkbook.RefreshAll
TWait = Time
TWait = DateAdd("s", 10, TWait)
Do Until TNow >= TWait
TNow = Time
Loop
fsname = xlApp.Application.GetSaveAsFilename
xlApp.ActiveWorkbook.SaveAs fileName:=fsname
xlApp.ActiveWorkbook.Close
fileName = Dir
If fileName <> "" Then
DoCmd.OpenQuery "QryDeleteCash", acViewNormal
End If
Loop
xlApp.Quit
Set xlApp = Nothing
' ...
Set qdf = db.QueryDefs("QryImport2")
db.Execute "QryImport2", dbFailOnError
For Each prm In qdf.Parameters
prm = Eval(prm.Name)
Next prm
qdf.Execute
' ...
INSERT INTO TblHolderCash ( FUND, Amount, Client )
SELECT DISTINCT TblInputSht.F1 AS FUND, TblInputSht.F2 AS AMOUNT, TblInputShtName.F1 AS Name
FROM TblInputSht, TblInputShtName
WHERE ((([TblInputSht].[F2]) Is Not Null));
qdf
and prm
object variables, and refactor like:Dim db As DAO.Database
Dim lngRowsAffected As Long
Dim lngRowsDeleted As Long
Dim fileName As Variant
Dim fsname As Variant
Dim xlApp As Excel.Application
Set db = CurrentDb
fileName = Dir("\\Svrfiles\access databases\Portfolio Test\")
Do While fileName <> ""
DoCmd.OpenQuery "QryDeleteCash", acViewNormal ' this can probably be: db.Execute "QryDeleteCash", dbFailOnError
DoCmd.TransferSpreadsheet acLink, , "TblInputSht", "\\Svrfiles\access databases\Portfolio Test\" & fileName, False, "Input Sheet!D6:E32"
DoCmd.TransferSpreadsheet acLink, , "TblInputShtName", "\\Svrfiles\access databases\Portfolio Test\" & fileName, False, "Input Sheet!E3:E3"
db.Execute "QryImport2", dbFailOnError
lngRowsAffected = db.RecordsAffected
DoCmd.DeleteObject acTable, "TblInputShtName"
DoCmd.DeleteObject acTable, "TblInputSht"
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
With .Workbooks.Open "\\Svrfiles\ACCESS DATABASES\cashrptgraph.xlsm", True, False
.RefreshAll
DoEvents
' The following 10 second delay seems quite long - perhaps DoEvents will take care of it?
TWait = Time
TWait = DateAdd("s", 10, TWait)
Do Until TNow >= TWait
TNow = Time
Loop
fsname = xlApp.Application.GetSaveAsFilename
.SaveAs fileName:=fsname
.Close
End With
fileName = Dir
' The following is not necessary as it happens at the beginning of the loop
' If fileName <> "" Then
' DoCmd.OpenQuery "QryDeleteCash", acViewNormal
' End If
End With
Loop
xlApp.Quit
Set xlApp = Nothing
Set db = Nothing
' ...
fileName = Dir("\\Svrfiles\access databases\Portfolio Test\")
' ...
' ...
fileName = Dir("\\Svrfiles\access databases\Portfolio Test\*.xls*")
' ...
Set xlApp = CreateObject("Excel.Application")
' ...
Set db = CurrentDb
Set xlApp = CreateObject("Excel.Application")
' ...
With .Workbooks.Open "\\Svrfiles\ACCESS DATABASES\cashrptgraph.xlsm", True, False 'needed to remove the with'
.RefreshAll 'needed to add .activeworkbook'
' ...
With xlApp
.Visible = True
With .Workbooks.Open("\\Svrfiles\ACCESS DATABASES\cashrptgraph.xlsm", True, False)
.RefreshAll[
' ...