Working in and out of Access and Excel

[mark curtis]

Dear all,

I want to enable users to be able to export the contents of a form to Excel and then allow them to inport any updates back. I can do the basic inport and export with docmd.TransferSpreadsheet BUT the help I need is error checking that the users has not added any new fields to the spreadsheet that the database will through out and I also want to either overwrite the data the user is going to import of delete the recordset of the form when they want to export the data.

any help much appreciated.
Thanks
Mark

 

[The_Doc_Man]

Overview:

To do "field-level" checking, you need to write some VBA code that has the Excel sheet open through an automation object. You could put this code underneath an action button on a form if that was convenient. The form itself need not be bound to anything if all you are going to do is import or check data.

In general the approach is:

set up an application object as an Excel instance.

Open a workbook object (a member of the collection of WorkBooks that is part of Excel objects) by the name of the file.

Activate the first worksheet (a member of the WorkSheets collection of the WorkBook object). It becomes the ActiveSheet.

Once you have a worksheet open, you can access the contents of each cell as

ActiveSheet.Cells(longROW, longCOLUMN).Value

Now, the bit about finding changes in the worksheet requires you to know the exact way in which the workbook was generated. If it was a direct export from a table, you will have to open the table as a recordset. If from a query, you will have to open up the query as a recordset.

Once the export source has been opened as a recordset you can step through the records in the set. Use a counter to track the correspondence between the recordset records and the worksheet rows. If the export was directly from query or table, then you can use a counter for columns, too. Because at that point,

recordset.Fields(longCOLUMN).Value should equal ...Cells(longROW, longCOLUMN).Value

The way to check whether something was added is to see if after .EOF on the recordset, the next row in the set isn't blank. Or when you have reached the limit of the number of fields in the record (recordset.Fields.Count), the next column isn't blank.

Also, you could define in your code that if a change occurred in a particular column, you would disallow it. Otherwise, while the recordset is open, you could update it with any auxiliary changes. (In that case, you will need to set up a .Edit for the recordset before you begin the changes and a .Update after.)

Be warned. This can be tedious as hell. But once you get the collections and object structure figured out, it becomes a lot easier. So if you are not familiar with the Component Object Model, I would advise great care and more than your normal attention to being EXTREMELY methodical. Like the old phrase my dear old Dad told me about carpentry: "measure twice, cut once."

 

[llkhoutx]

I'd avoid using Excel automation. It's frought with user induced errors.

On transfering the spreadsheet back into Access, transfer it to a temporary table, validate the fields with VBA code, and if all correct, copy the temporary table into the real table and delete the temporary table.

 

[Rx_]

From Access, create a Standard Report in Excel.
No query stored in Access.
With the visible FALSE, the user never sees this. The user just opens up the finished product from the hard (or network) drive.
Takes about 3 seconds to run a medium size query.
This is an extremely simple report to get user input for better ones.

Option Compare Database
Public Function StandardReportExcel()
Dim objXL                   As Excel.Application
Dim XLWB                    As Excel.Workbook
Dim XLWS                    As Excel.Worksheet
Dim strSQL                  As String
Dim rsData                  As DAO.Recordset
Dim intMaxRecordCount       As Integer
Dim intMaxColCount          As Integer
Dim sngTimer                As String
Dim sngTotalTime            As Single
Dim blnTestMode             As Boolean
Dim strNewReportPath        As String  ' for directory to save
Dim intWorksheetNum         As Integer
Dim intRowNumber            As Integer
Dim intColumnNumber         As Integer
Dim intRowPos               As Integer
Dim VBQuote                 As String  ' move this to global later
Dim intHeaderColCount       As Integer
Dim intMaxheaderColCount    As Integer
Dim strSaveAsFileName       As String  ' the name with time stamp to save this report
Dim rnOmrade                As Range
Dim vaData                  As Variant
Dim i                       As Integer
Dim StartTimer              As Long
Dim StopTimer               As Long
Dim TotalTime               As Long
' In Access, set a reference to Microsoft Excel Applicaiton - This code can be put into a code module and called from a click event
On Error GoTo PROC_ERROR
VBQuote = Chr$(34)                                  ' will add this to global later - for now just trying to get code into production in 4 minute window
On Error Resume Next
 
On Error GoTo PROC_ERROR
50      strNewReportPath = "m:\StandardReport"  ' your path may vary
                                                    ' ----------- Set objects in Excel
100     StartTimer = Timer
        DoEvents
110     blnTestMode = True                          ' ------- change to false for production ------
        On Error GoTo 0
120     If objXL Is Nothing Then
130         Set objXL = New Excel.Application
140         objXL.EnableEvents = False
150     Else
160     Excel.Application.Quit
170     Set objXL = New Excel.Application
180     objExcel.EnableEvents = False
End If
On Error GoTo PROC_ERROR
201     objXL.Visible = True                        ' Change to FASLE for final Production! this is for debugging
210     objXL.Workbooks.Add
220     'objXL.Worksheets.Add
230     intWorksheetNum = 1
235     'objXL.Visible = False
240     intRowPos = 1
250     objXL.Worksheets(intWorksheetNum).Cells(intRowPos, 1) = "Created: " & Now()
260        objXL.Worksheets(intWorksheetNum).Name = "StdRpt"
                                                    ' --- Create Query in variable
630     ' Create an query in Access, then past your SQL below. This code is here to help understand the parsing and the vbquotes in the query
        ' This creates the record set dynamically during run time. You don't need to store a query in Access.
640     strSQL = "SELECT Wells.Well_Name, Wells_Status1.Status1 AS Well_status, States.State, Wells_County.County, " & _
                "ORDER_Status_1.ORDER_Status AS State_Status, ORDER_State.Dt_ORDER_Sub AS State_Sub, ORDER_State.Dt_ORDER_Apv AS State_Dt_App, " & _
                "IIf(IsNull([State_Sub]) And IsNull([State_Dt_App])," & VBQuote & VBQuote & " ,IIf(IsNull([State_Dt_App])," & Chr(34) & "Pending" & Chr(34) & ",[State_Dt_App]-[State_sub])) AS St_No_Days, " & _
                "ORDER_State.Dt_ORDER_Exp AS State_Dt_Expire, " & _
                "ORDER_Status.ORDER_Status AS Fed_Status, ORDER_Fed.Dt_ORDER_Sub AS Fed_Sub, ORDER_Fed.Dt_ORDER_Apv AS Fed_Dt_App, " & _
                "IIf(IsNull([Fed_Sub]) And IsNull([Fed_Dt_App])," & VBQuote & VBQuote & " ,IIf(IsNull([Fed_Dt_App])," & Chr(34) & "Pending" & Chr(34) & ",[Fed_Dt_App]-[Fed_sub])) AS Fed_No_Days, " & _
                "ORDER_Fed.Dt_ORDER_Exp AS Fed_Dt_Expire " & _
                "FROM Wells_Status1 INNER JOIN ((((States INNER JOIN Wells_County ON States.ID_State = Wells_County.ID_State) " & _
                "INNER JOIN Wells ON Wells_County.ID_County = Wells.ID_County) " & _
                "LEFT JOIN (ORDER_Status RIGHT JOIN ORDER_Fed ON ORDER_Status.ID_ORDER_Status = ORDER_Fed.ID_ORDER_Status) ON Wells.ID_Wells = ORDER_Fed.ID_Wells) " & _
                "LEFT JOIN (ORDER_State LEFT JOIN ORDER_Status AS ORDER_Status_1 ON ORDER_State.ID_ORDER_Status = ORDER_Status_1.ID_ORDER_Status) " & _
                "ON Wells.ID_Wells = ORDER_State.ID_Wells) ON Wells_Status1.ID_WellStatus1 = Wells.ID_WellsStatus1;"
        'Debug.Print strSQL
650         Set rsData = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)                                  ' Snapshots are faster
660         intRowPos = 5                                                                                 ' Sets starting Row for data in Excel - reference fields to this
670         objXL.Worksheets(intWorksheetNum).Cells(intRowPos, 1).CopyFromRecordset rsData                ' copies snapshot into Excel
680         intMaxRecordCount = rsData.RecordCount - 1                                                      ' - use for max rows returned in formatting later
                                                        ' ------- Create Header in new Excel based on Query
700       intMaxheaderColCount = rsData.Fields.count - 1
710       For intHeaderColCount = 0 To intMaxheaderColCount
730           If Left(rsData.Fields(intMaxheaderColCount).Name, 3) <> "xxx" Then  ' Future use - adding xxx in cross tab queries for fields to exclude
740               objXL.Worksheets(intWorksheetNum).Cells(intRowPos - 1, intHeaderColCount + 1) = rsData.Fields(intHeaderColCount).Name    ' Relative to intRowPos
750           End If
760       Next intHeaderColCount
 
780       objXL.Rows((intRowPos - 1) & ":" & (intRowPos - 1)).Select                                    ' Selection for Bold header column (can make 2 if needed)
790       objXL.Selection.Font.Bold = True
        ' Just a bunch of bloated formatting for the cells for beginners. Normally, this gets compressed using the With statement.
800     With objXL.Selection.Font
            .Name = "Arial"
            .Size = 12
            .ThemeColor = xlThemeColorLight1
         End With
         With objXL.Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ThemeColor = 10
            .TintAndShade = -0.499984740745262
            .Weight = xlThick
        End With
        With objXL.Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
        End With
        With objXL.Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
        End With
        objXL.Rows("4:4").RowHeight = 24
        objXL.Rows("4:4").RowHeight = 32.25
        objXL.Rows("4:4").RowHeight = 25.5
        With objXL.Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
        End With
        With objXL.Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ThemeColor = 10
            .TintAndShade = -0.499984740745262
            .Weight = xlThick
        End With
        With objXL.Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
        With objXL.Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
 
900      objXL.Cells.EntireColumn.AutoFit               ' After the data and headers are completed, autofit the entire sheet to fit
910     DoEvents
                                        ' ------------------------- Omitted a bunch of customer headers ----------------
    DoEvents
On Error Resume Next                    ' ------------------------ End Custom Headers ---------------------------------
                                        ' ------------------------ Start Column Formatting ----------------------------
                                        ' objXL.Selection.NumberFormat = "m/d/yyyy"
                                        'objXL.Visible = True
                                        ' Any column that SQL uses formula to return number & text combination needs to be custom formated
' Column H and M returned numbers as "text" so the SubTotal function won't work. This converts Text to Numeric
' but also leaves the text words "pending" in place. It also keeps the blanks from turning into zeros that affects my Average function.
Set rnOmrade = objXL.ActiveSheet.Range(objXL.Range("H5"), objXL.Range("H6536").End(xlUp))
vaData = rnOmrade.Value
For i = 1 To UBound(vaData)   ' data base record set returns "Pending", blank or a number
            If (vaData(i, 1) = "Pending") Then
                vaData(i, 1) = "Pending"
            ElseIf ((vaData(i, 1) * 1) = 0) Then
                vaData(i, 1) = ""
            Else
                vaData(i, 1) = vaData(i, 1) * 1
 
            End If
            'vaData(i, 1) = IIf(IsNumeric(vaData(i, 1) * 1), vaData(i, 1) * 1, vaData(i, 1))
Next i
Err.Clear                   ' one unknown variant type can mess up the whole array
rnOmrade.Value = vaData
Set rnOmrade = Nothing
Set rnOmrade = objXL.ActiveSheet.Range(objXL.Range("M5"), objXL.Range("M6536").End(xlUp))
vaData = rnOmrade.Value
For i = 1 To UBound(vaData)   ' data base record set returns "Pending", blank or a number
            If (vaData(i, 1) = "Pending") Then
                vaData(i, 1) = "Pending"
            ElseIf ((vaData(i, 1) * 1) = 0) Then
                vaData(i, 1) = ""
            Else
                vaData(i, 1) = vaData(i, 1) * 1
 
            End If
            'vaData(i, 1) = IIf(IsNumeric(vaData(i, 1) * 1), vaData(i, 1) * 1, vaData(i, 1))
Next i
Err.Clear                   ' one unknown variant type can mess up the whole array
rnOmrade.Value = vaData
 
 
 
        DoEvents
On Error GoTo PROC_ERROR
'       More fancy formatting and the use of the AutoFilter
1700    objXL.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            'objXL.Rows("4:4").Select
1720    objXL.Rows((intRowPos - 1) & ":" & (intRowPos - 1)).Select              ' based on relative position for where data starts above
    objXL.Selection.AutoFilter                                              ' ---------------    Autofilter --------------- Autofilter -----------
                                                                            ' Need to set blank cells here for subTotal function to work
                                                                           ' copy recordset adds hidden text due to formula - use array to convert to numeric
 
' Subtotals added on header over specific columns based on your Query.
' In this case - the numeric data is on columns H and M
' This adds the subtotal function on the top that totals only visible rows after the autofilter is used.
 
    ' STATE number of Days formula
1900    objXL.Range("G1").Select
1910    objXL.ActiveCell.FormulaR1C1 = "Max Days"
1920    objXL.Range("G2").Select
1930    objXL.ActiveCell.FormulaR1C1 = "Average Days"
1940    objXL.Range("H1").Select
1050    objXL.ActiveCell.FormulaR1C1 = "=SUBTOTAL(104,R[4]C:R[579]C)"
1960    objXL.Range("H2").Select
1970    objXL.ActiveCell.FormulaR1C1 = "=SUBTOTAL(101,R[3]C:R[5798]C)"
 
 
    ' Federal number of days formula
2000    objXL.Range("L1").Select
2010    objXL.ActiveCell.FormulaR1C1 = "Max Days"
2020    objXL.Range("L2").Select
2030    objXL.ActiveCell.FormulaR1C1 = "Average Days"
2040    objXL.Range("M1").Select
2050    objXL.ActiveCell.FormulaR1C1 = "=SUBTOTAL(104,R[4]C:R[579]C)"
2060     objXL.Range("M2").Select
2070   objXL.ActiveCell.FormulaR1C1 = "=SUBTOTAL(101,R[3]C:R[5798]C)"
2090    StopTimer = Timer
2100    TotalTime = StopTimer - StartTimer
 
    ' Time stamp for Excel to be created, data to be retrieved
    ' My old computer takes 3 seconds to pull the data, create a custom spread sheet report and save it to disk
2110    objXL.Range("A2").Select
2120    objXL.ActiveCell.FormulaR1C1 = "Code Completed in " & CStr(Format(TotalTime, "0.00")) & " seconds"
 
 
2200        'objXL.Application.GoTo Reference:="NamedRange"  ' create some named range to highlight before saving ' future
2210        objXL.Application.Calculation = xlAutomatic
2220        objXL.ActiveWorkbook.PrecisionAsDisplayed = False
                                                                            ' Future for security addition
2230        If CurrentUser <> "Admin" And CurrentUser <> "SomeUSERNAME" And blnTestMode = False Then
2240            objXL.ActiveWorkbook.SaveAs FileName:=strNewReportPath
2250        End If
2280        'objXL.ActiveWorkbook.SaveAs
2290        strSaveAsFileName = strNewReportPath & "\" & Year(Now()) & "-" & Month(Now()) & "-" & Day(Now()) & "-" & Hour(Now()) & "-" & Minute(Now()) & "-" & " Standard Report.xlsx"
2300        objXL.ActiveWorkbook.SaveAs FileName:=strSaveAsFileName
2320        objXL.Visible = True
2325            objXL.Application.Quit
            ' I don't let users look at it but a second. They can go find it saved on a drive and open it.
2330        MsgBox "Please open My Documents folder and find your Excel Standard Report named: " & strSaveAsFileName, vbOKOnly, "Testing new style Excel Report"
 
3010        Debug.Print sngTotalTime, "Code Completed in " & CStr(Format(sngTotalTime, "0.00")) & " sec."
PROC_EXIT:
10010   On Error Resume Next
10020   'objXL.ActiveWindow.Close False
10050   Set objXL = Nothing
11290      On Error Resume Next
11300      Exit Function
PROC_ERROR:
11310      Select Case Err.Number
              'Case ###
              Case Else
11320              'fLogError Err.Number, Erl, Err.Description, "basExcelBasisSummary", "MakeBaseload", True
                    ' later  - use central error funciton I designed
11330                       'objXL.Quit
11340                       'objXL.Close
11350              Resume PROC_EXIT
11370      End Select
 
End Function

 

[ghudson]

Why are you not doing everything in Access? Only way to control what you want or do not want the users to do with the data.

 

[SOS]

Option Compare Database
Public Function StandardReportExcel()
...truncated for space

The posted code could really be optimized. For example, you do not need to select a cell in order to get or alter its contents.

For a lot of things you do not need to select it to do anything to it. Just don't use the ActiveSheet, ActiveCell, etc. for setting the values. Use the range or cells method instead.

I'm sure that there is more, but I did want to mention that little tidbit as it was something that escaped me for quite a while until someone pointed it out to me.

 

[Rx_]

' In Access, set a reference to Microsoft Excel Applicaiton to run this code from Access - with visible False so the user never sees Excel or touches it.

Very Good point. using the Range and cells with offsets is more efficient.
Trying to help some self-taught (and there is nothing wrong with that) brand-new Access users that have grasp the QBE and Excel Recorder.
Thought it might be useful to someone at that level.
But.. it is very verbose to be sure. I promise to keep it shorter from now on.

While I have your attention... Would really like your idea about the ActiveSheet.
Regarding the ActiveSheet:
Set rnOmrade = objXL.ActiveSheet...
I just posted how this part of the Range gets an Object error if someone runs the same report more than once.
The solution found for what was called a known error, was to use the ActiveSheet. It evidetnly clears out a Global Object error.

A better way to avoid the global Object error than using the ActiveSheet was very elusive. Any Ideas?