|
Question : Problems saving an excel workbook in Access vba
|
|
Hi Experts,
I am having problems saving an excel workbook in access vba code. It doesn't do anything. I did ot write the code but have been trying to make updates to it. It used to work apparently but now isn't.
When it gets to the line where it is supposed to save the workbook to a .xlsw extension, it just bypasses it. I suspect the issue might be with the fact that it may want me to explicitly declare the excel objects in the code.
Thanks,
Definit1
Code Snippet:
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
|
Private Sub cmdUploadActivity_Click()
On Error GoTo Proc_Err
If MsgBox("Please be sure that you are uploading a NEW FILE!!" & vbCrLf _
& "There will be a DELAY gathering and updating data.", vbOKCancel, "Delay") = vbCancel Then
Exit Sub
End If
Me.Visible = True
'IF EXCEL IS OPEN, USE IT, OTHERWISE, OPEN NEW SESSION
'Why brother why...?
'Dim xlApp As Excel.Application
Dim xlObj As Object
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim xlrange As Excel.Range
Const ERR_APP_NOTRUNNING As Long = 429
On Error Resume Next
'Why brother why...?
'Set xlApp = GetObject(, "Excel.Application")
Set xlObj = CreateObject("excel.application")
If Err = ERR_APP_NOTRUNNING Then
'Why brother why...?
'Set xlApp = New Excel.Application
End If
'Dim xlWB As Excel.Workbook
'OPEN EXCEL INVISIBLY, FORMAT ACTIVITY.DNL AND SAVE AS ACTIVITY.XLSX
'Why brother why...?
'With xlApp
With xlObj
'Why brother why...?
'.Visible = False
.Visible = True
'TURN EXCEL WARNINGS OFF
.Application.DisplayAlerts = True
'Why brother why...?
'Set xlWB = .Workbooks.Open(strWorkFolder & "activity.dnl", , False)
xlObj.Workbooks.Open (strWorkFolder & "activity.dnl")
Set xlbook = .Workbooks("activity")
Set xlsheet = xlbook.ActiveSheet
'CLEAN ACTIVITY.DNL FILE BEFORE IMPORTING
'REMOVE ALL DOUBLE SPACES
xlsheet.Cells.Select
.Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'REMOVE ALL DOUBLE QUOTES
.Cells.Select
.Selection.Replace What:="""", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Range("A1").Select
'REMOVE ALL UNNECESSARY ZEROS
.ActiveCell.Cells.Select
.ActiveCell.Activate
.Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'SAVE AS NEW EXCEL FILE ACTIVITY.XLSX
xlbook.ActiveWorkbook.SaveAs FileName:= _
strWorkFolder & "Activity.xlsw", FileFormat:=51, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
'SAVE ACTIVITY.DNL AS ACTIVITY.XLS AND CLOSE BOTH
.Range("A1").Select
.ActiveWorkbook.SaveAs FileName:= _
strWorkFolder & "Activity.xlsx", FileFormat:=51, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
''TURN EXCEL WARNINGS BACK ON
'.Application.DisplayAlerts = True
'CLOSE EXCEL
'Why brother why...?
'xlApp.Quit
'Set xlApp = Nothing
xlObj.Quit
Set xlObj = Nothing
'CREATE ACTIVITY TABLE FROM EXCEL ACTIVITY.XLSX
DoCmd.TransferSpreadsheet acImport, 8, "activity", _
strWorkFolder & "Activity.xlsx", True, ""
'DELETE ACTIVITY.XLSX
Dim KillFile As String
KillFile = strWorkFolder & "Activity.xlsx"
'CHECK THAT FILE EXISTS
If Len(Dir$(KillFile)) > 0 Then
'FIRST REMOVE READONLY ATTRIBUTE, IF SET
SetAttr KillFile, vbNormal
'THEN DELETE THE FILE
Kill KillFile
End If
End With
Dim strSql As String
strSql = ""
strSql = "INSERT INTO tblSecurities ( scr_DateOfGift, scr_Symbol," _
& "scr_Explanation, scr_Quantity_Orig, scr_Quantity_New, scr_Description," _
& "scr_BrokerAccount, scr_LastUpdate ) "
strSql = strSql & "SELECT [Settle Date], Symbol, Explanation," _
& "Quantity, Quantity, Left([Description],50), 'ML' AS BrokerAccount, Now() As LastUpdate "
strSql = strSql & "FROM activity "
strSql = strSql & "WHERE (((Explanation)='JOURNAL ENTRY' Or" _
& "(Explanation)='RECEIVED' Or (Explanation)='CUST ACCT TRFR')) "
strSql = strSql & "ORDER BY activity.[Settle Date] DESC;"
DoCmd.SetWarnings False
DoCmd.RunSQL (strSql)
DoCmd.SetWarnings True
'DELETE ACCESS ACTIVITY TABLE
DoCmd.DeleteObject acTable, "activity"
Me.Visible = True
Me.hiddenUpdate.SetFocus
Me.cmdUploadActivity.SetFocus
'RESET RECORDSOURCE
strSql = ""
strSql = strSql & "SELECT tblSecurities.scr_SecID, tblSecurities.scr_AdvID," _
& "tblSecurities.scr_Add, tblSecurities.scr_Remove, tblSecurities.scr_Deleted," _
& "tblSecurities.scr_DateOfGift, tblSecurities.scr_Symbol, tblSecurities.scr_Explanation," _
& "tblSecurities.scr_Quantity_Orig, tblSecurities.scr_Quantity_New," _
& "tblSecurities.scr_Description, tblSecurities.scr_HighValue, tblSecurities.scr_LowValue," _
& "tblSecurities.scr_BookValue, tblSecurities.scr_BrokerAccount, tblSecurities.scr_JournalID," _
& "tblSecurities.scr_JournalDate, tblSecurities.scr_LastUpdate"
strSql = strSql & " from tblSecurities"
strSql = strSql & " WHERE (((tblSecurities.scr_AdvID) Is Null)" _
& "AND ((tblSecurities.scr_Deleted)=False))"
strSql = strSql & " ORDER BY tblSecurities.scr_SecID;"
Me.RecordSource = strSql
Proc_Exit:
DoCmd.SetWarnings True
Exit Sub
Proc_Err:
Resume Proc_Exit
End Sub
|
|
|
|
Answer : Problems saving an excel workbook in Access vba
|
|
The first thing to do is remove On Error ... stuff, especially On Error Resume Next.
That could be causing the save to be skipped if it is causing an error.
One of the most likely reasons for the save causing an error could be because of a problem with the path
or filename that it's trying to use.
In the code the path seems to be in the variable strWorkFolder, but that isn't defined/declare anywhere.
And if, as Tony wonders, it's a mapped drive then you should look into using the UNC path.
With the UNC path the letter of the mapped drive wouldn't be needed.
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
|
Private Sub cmdUploadActivity_Click()
Dim xlObj As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim xlrange As Excel.Range
Dim KillFile As String
Dim strSql As String
If MsgBox("Please be sure that you are uploading a NEW FILE!!" & vbCrLf _
& "There will be a DELAY gathering and updating data.", vbOKCancel, "Delay") = vbCancel Then
Exit Sub
End If
Set xlObj = CreateObject("excel.application")
With xlObj
.Visible = True
.Application.DisplayAlerts = True
.Workbooks.Open (strWorkFolder & "activity.dnl")
Set xlbook = .Workbooks("activity")
Set xlsheet = xlbook.ActiveSheet
'REMOVE ALL DOUBLE SPACES
With xlsheet.Cells
.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
End With
'SAVE AS NEW EXCEL FILE ACTIVITY.XLSX
xlbook.SaveAs Filename:=strWorkFolder & "Activity.xlsw", FileFormat:=51
xlbook.SaveAs Filename:=strWorkFolder & "Activity.xlsx", FileFormat:=51
.Quit
End With
Set xlObj = Nothing
'CREATE ACTIVITY TABLE FROM EXCEL ACTIVITY.XLSX
DoCmd.TransferSpreadsheet acImport, 8, "activity", strWorkFolder & "Activity.xlsx", True, ""
'DELETE ACTIVITY.XLSX
KillFile = strWorkFolder & "Activity.xlsx"
'CHECK THAT FILE EXISTS
If Len(Dir$(KillFile)) > 0 Then
'FIRST REMOVE READONLY ATTRIBUTE, IF SET
SetAttr KillFile, vbNormal
'THEN DELETE THE FILE
Kill KillFile
End If
strSql = "INSERT INTO tblSecurities ( scr_DateOfGift, scr_Symbol," _
& "scr_Explanation, scr_Quantity_Orig, scr_Quantity_New, scr_Description," _
& "scr_BrokerAccount, scr_LastUpdate ) "
strSql = strSql & "SELECT [Settle Date], Symbol, Explanation, Quantity, Quantity, Left([Description],50), 'ML' AS BrokerAccount, Now() As LastUpdate "
strSql = strSql & "FROM activity "
strSql = strSql & "WHERE (((Explanation)='JOURNAL ENTRY' Or (Explanation)='RECEIVED' Or (Explanation)='CUST ACCT TRFR')) "
strSql = strSql & "ORDER BY activity.[Settle Date] DESC;"
DoCmd.SetWarnings False
DoCmd.RunSQL (strSql)
DoCmd.SetWarnings True
'DELETE ACCESS ACTIVITY TABLE
DoCmd.DeleteObject acTable, "activity"
Me.Visible = True
Me.hiddenUpdate.SetFocus
Me.cmdUploadActivity.SetFocus
'RESET RECORDSOURCE
strSql = strSql & "SELECT tblSecurities.scr_SecID, tblSecurities.scr_AdvID," _
& "tblSecurities.scr_Add, tblSecurities.scr_Remove, tblSecurities.scr_Deleted," _
& "tblSecurities.scr_DateOfGift, tblSecurities.scr_Symbol, tblSecurities.scr_Explanation," _
& "tblSecurities.scr_Quantity_Orig, tblSecurities.scr_Quantity_New," _
& "tblSecurities.scr_Description, tblSecurities.scr_HighValue, tblSecurities.scr_LowValue," _
& "tblSecurities.scr_BookValue, tblSecurities.scr_BrokerAccount, tblSecurities.scr_JournalID," _
& "tblSecurities.scr_JournalDate, tblSecurities.scr_LastUpdate"
strSql = strSql & " FROM tblSecurities"
strSql = strSql & " WHERE (((tblSecurities.scr_AdvID) Is Null)AND ((tblSecurities.scr_Deleted)=False))"
strSql = strSql & " ORDER BY tblSecurities.scr_SecID;"
Me.RecordSource = strSql
DoCmd.SetWarnings True
End Sub
|
|
|
|
|
|
