Update Excel Sheet from Access

I have an Excel sheet that I would like to update from Access. I would like to add Columns P (Report Date) and Q (Contractor) and then update (fill) the two columns  based on information in cells A2 (Report Date) and A3. Thanks

ReportReport.JPG
shieldscoAsked:
Who is Participating?
 
Fabrice LambertFabrice LambertCommented:
Dale, you silently save no matter what ?
Eww, in case of troubles, it is better to not save anything IMO, else there is a risk for the file to be in inconsistant state.

Here is my version, I prefer working on array than on Excel cells (faster processing), and of course 2 procedures by respect for SRP:
Option Explicit

Public Sub updateWorkbook(ByVal path As String)
On Error GoTo Error
    Dim app As Object       '// Excel.Application
    Dim wb As Object        '// Excel.Workbook
    Dim ws As Object        '// Excel.Worksheet
    
    Set app = CreateObject("Excel.Application")
    Set wb = app.Workbooks.Open("c:\............")
    Set ws = wb.Worksheets("myWorksheetName")
    updateWorksheet ws
    Set ws = Nothing
    wb.Save
    ws.Close
    app.Quit
Exit Sub
Error:
    Dim errMsg As String

    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        wb.Close False
        Set wb = Nothing
    End If
    If Not (app Is Nothing) Then
        app.Quit
        Set app = Nothing
    End If
    errMsg = vbNullString
    errMsg = errMsg & "The application encountered the following execution error:" & vbCrLf & vbCrLf
    errMsg = errMsg & Err.Description
    MsgBox errMsg, vbOKOnly + vbCritical, "Error"
End Sub

Private Sub updateWorksheet(ByRef ws As Excel.Worksheet)
On Error GoTo Error
    Dim rng As Object       '// Excel.Range
    Dim data() As Variant
    Dim totalRows As Long
    Dim totalCols As Long
    Dim i As Long
    Dim Xref As Long
    Dim Yref As Long
    
    data = ws.UsedRange
    Xref = LBound(data, 1)
    Yref = LBound(data, 2)
    ReDim Preserve data(Xref To UBound(data, 1), Yref To UBound(data, 2) + 2)
    totalRows = UBound(data, 1) - Xref
    totalCols = UBound(data, 2) - Yref
    
    data(Xref + 3, Yref + 14) = "Report date"
    data(Xref + 3, Yref + 15) = "Contractor"
    For i = Xref + 4 To UBound(data, 1)
        data(i, Yref + 14) = "=$A$2"
        data(i, Yref + 15) = "=$A$3"
    Next
    Set rng = ws.Range("A1")
    Set rng = ws.Range(rng, rng.Offset(totalRows, totalCols))
    rng = data
    Set rng = Nothing
Exit Sub
Resume
Error:
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Open in new window

0
 
Dale FyeCommented:
Why don't you just create a formula in those two columns which point to those to cells in the spreadsheet.  Then drag those formulas down to the end of the spreadsheet?

I mean, you could do this in Access, but unless Access is populating the rest of the spreadsheet, why?
0
 
shieldscoAuthor Commented:
I need to automate the process from Access. We get new files everyday and I don't want the end user to add formulas for each new file.
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Dale FyeCommented:
So, are you going to upload the data from the spreadsheets into Access as well?

Generally automation of excel looks something like:

Public Sub UpdateExcel()

    Dim objXL As Object     'Excel.Application
    Dim objWbk As Object    'Excel.Workbook
    Dim objSht As Object    'Excel.Worksheet
    
    Dim intRow As Integer
    Dim Value1 As String
    Dim Value2 As String
    
    Set objXL = CreateObject("Excel.Application")
    objXL.Visible = true 
    Set objWbk = objXL.Workbooks.Open("C:\yourFilename.xlsx")
    Set objSht = objWbk.Sheets(1)
    
    Value1 = objSht.Cells(2, 1)
    Value2 = objSht.Cells(3, 1)
    
    intLoop = 5
    objSht.Cells(intRow, 16).Value = "Report Date"
    objSht.Cells(intRow, 17).Value = "Contractor"
    
    Do
        intRow = intRow + 1
        If objSht.Cells(intRow, 1) = "" Then Exit Do
        objSht.Cells(intRow, 16).Value = Value1
        objSht.Cells(intRow, 17).Value = Value2
    Loop
    
ProcExit:
    On Error Resume Next
    Set objSht = Nothing
    If (objWbk Is Nothing) = False Then
        objWbk.Close SaveChanges:=True
        Set objWbk = Nothing
    End If
    If (objXL Is Nothing) = False Then
        objXL.Quit
        Set objXL = Nothing
    End If
    Exit Sub
    
ProcError:
    Debug.Print "UpdateExcel", Err.Number, Err.Description
    MsgBox Err.Number & vbCrLf & Err.Description, , "UpdatExcel"
    Resume ProcExit
    
End Sub

Open in new window

This code would loop through every row of the spreadsheet and update the 16th and 17th columns (make sure you have those #'s right) as long as there is a value in the 1st column.  It is critical that you close the excel objects and cleanup the object variables, or you will end up with roque instances of Excel visible in the TaskManager, but not in the taskbar.
0
 
shieldscoAuthor Commented:
Runtime error 1004 on line:

objSht.Cells(intRow, 17).Value = "Contractor"

Error
0
 
shieldscoAuthor Commented:
Compile error

Error
0
 
Fabrice LambertFabrice LambertCommented:
Replace the parameter type from Excel.worksheet to Object ...
0
 
shieldscoAuthor Commented:
compile error
xxx
0
 
Fabrice LambertFabrice LambertCommented:
Cmon, replace the parameters to fit your needs
Set wb = app.Workbooks.Open("c:\............")  '// adjust the workbook's path here
    Set ws = wb.Worksheets("myWorksheetName") '// adjust the worksheet name here

Open in new window

Common sens .......
0
 
shieldscoAuthor Commented:
I did change

Public Sub updateWorkbook(ByVal path As String)
On Error GoTo Error
    Dim app As Object       '// Excel.Application
    Dim wb As Object        '// Excel.Workbook
    Dim ws As Object        '// Excel.Worksheet
   
    Set app = CreateObject("Excel.Application")
    Set wb = app.Workbooks.Open("U:\Serial Claims DB\Contractor Imports\JB Serial Claims OMHA 111517 - Copy - Copy.xlsx")
    Set ws = wb.Worksheets("Sheet1")
    updateWorksheet ws
    Set ws = Nothing
    wb.Save
    ws.Close
    app.Quit
Exit Sub
Error:
    Dim errMsg As String

    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        wb.Close False
        Set wb = Nothing
    End If
    If Not (app Is Nothing) Then
        app.Quit
        Set app = Nothing
    End If
    errMsg = vbNullString
    errMsg = errMsg & "The application encountered the following execution error:" & vbCrLf & vbCrLf
    errMsg = errMsg & Err.Description
    MsgBox errMsg, vbOKOnly + vbCritical, "Error"
End Sub

Private Sub updateWorksheet(ByRef ws As Object)
On Error GoTo Error
    Dim rng As Object       '// Excel.Range
    Dim data() As Variant
    Dim totalRows As Long
    Dim totalCols As Long
    Dim i As Long
    Dim Xref As Long
    Dim Yref As Long
   
    data = ws.UsedRange
    Xref = LBound(data, 1)
    Yref = LBound(data, 2)
    ReDim Preserve data(Xref To UBound(data, 1), Yref To UBound(data, 2) + 2)
    totalRows = UBound(data, 1) - Xref
    totalCols = UBound(data, 2) - Yref
   
    data(Xref + 3, Yref + 14) = "Report date"
    data(Xref + 3, Yref + 15) = "Contractor"
    For i = Xref + 4 To UBound(data, 1)
        data(i, Yref + 14) = "=$A$2"
        data(i, Yref + 15) = "=$A$3"
    Next
    Set rng = ws.Range("A1")
    Set rng = ws.Range(rng, rng.Offset(totalRows, totalCols))
    rng = data
    Set rng = Nothing
Exit Sub
Resume
Error:
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
0
 
Fabrice LambertFabrice LambertCommented:
ok, my apologies: the procedure updateWorkbook don't need parameters.
0
 
shieldscoAuthor Commented:
I don't follow
0
 
shieldscoAuthor Commented:
Compile error

aaaa
0
 
Fabrice LambertFabrice LambertCommented:
Public Sub updateWorkbook() instead of Public Sub updateWorkbook(ByVal path As String)
0
 
shieldscoAuthor Commented:
Error

1
2
4
0
 
Fabrice LambertFabrice LambertCommented:
On the first error, another mistake from me, the line should be:
wb.close

On the 2nd, it is obvious:
The workbook is read only, you'll need to investigate why.
Is it already open ?
Is it placed in a read only directory ?
check what your database do before calling the function.
0
 
shieldscoAuthor Commented:
The only issue is that  #NA is written out to Column R




Column

Public Sub updateWorkbook()
On Error GoTo Error
    Dim app As Object       '// Excel.Application
    Dim wb As Object        '// Excel.Workbook
    Dim ws As Object        '// Excel.Worksheet
   
    Set app = CreateObject("Excel.Application")
    Set wb = app.Workbooks.Open("U:\Serial Claims DB\Contractor Imports\JB Serial Claims OMHA 111517 - Copy - Copy.xlsx")
    Set ws = wb.Worksheets("Sheet1")
    updateWorksheet ws
    Set ws = Nothing
    wb.Save
    wb.Close
    app.Quit
Exit Sub
Error:
    Dim errMsg As String

    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        wb.Close False
        Set wb = Nothing
    End If
    If Not (app Is Nothing) Then
        app.Quit
        Set app = Nothing
    End If
    errMsg = vbNullString
    errMsg = errMsg & "The application encountered the following execution error:" & vbCrLf & vbCrLf
    errMsg = errMsg & Err.Description
    MsgBox errMsg, vbOKOnly + vbCritical, "Error"
End Sub

Private Sub updateWorksheet(ByRef ws As Excel.Worksheet)
On Error GoTo Error
    Dim rng As Object       '// Excel.Range
    Dim data() As Variant
    Dim totalRows As Long
    Dim totalCols As Long
    Dim i As Long
    Dim Xref As Long
    Dim Yref As Long
   
    data = ws.UsedRange
    Xref = LBound(data, 1)
    Yref = LBound(data, 2)
    ReDim Preserve data(Xref To UBound(data, 1), Yref To UBound(data, 2) + 2)
    totalRows = UBound(data, 1) - Xref
    totalCols = UBound(data, 2) - Yref
   
    data(Xref + 4, Yref + 15) = "Report Date"
    data(Xref + 4, Yref + 16) = "Contractor"
    For i = Xref + 5 To UBound(data, 1)
        data(i, Yref + 15) = "=RIGHT($A$2,6)"
        data(i, Yref + 16) = "=Right($A$3,5)"
    Next
    Set rng = ws.Range("A1")
    Set rng = ws.Range(rng, rng.Offset(totalRows, totalCols))
    rng = data
    Set rng = Nothing
Exit Sub
Resume
Error:
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub
0
 
shieldscoAuthor Commented:
Final Code: notice that the code loops through all xls* in the selected folder and updates the Report Date and Contractor columns

Public Sub updateWorkbook()
On Error GoTo Error
    Dim app As Object       '// Excel.Application
    Dim wb As Object        '// Excel.Workbook
    Dim ws As Object        '// Excel.Worksheet
    Dim strPathFile As String, strFile As String, strPath As String
    Dim strTable As String, strBrowseMsg As String
 

strBrowseMsg = "Select the folder that contains the Contractor EXCEL files:"

strPath = BrowseFolder(strBrowseMsg)

If strPath = "" Then
       MsgBox "No folder was selected.", vbOKOnly + vbInformation, "OMHA"
       Exit Sub
 End If



 strFile = Dir(strPath & "\*.xls*")
 Do While Len(strFile) > 0
       strPathFile = strPath & "\" & strFile
       
       
          


       strFile = Dir()

    
    Set app = CreateObject("Excel.Application")
    Set wb = app.Workbooks.Open(strPathFile)
    Set ws = wb.Worksheets("Sheet1")
    updateWorksheet ws
    
    wb.Worksheets("Sheet1").Range("R:HFD").Delete
    
    Set ws = Nothing
    wb.Save
    wb.Close
    app.Quit
    
     Loop
     
                    MsgBox "All Contractor columns updated...........", vbOKOnly + vbInformation, "OMHA"

    
Exit Sub


Error:
    Dim errMsg As String

    If Not (ws Is Nothing) Then
        Set ws = Nothing
    End If
    If Not (wb Is Nothing) Then
        wb.Close False
        Set wb = Nothing
    End If
    If Not (app Is Nothing) Then
        app.Quit
        Set app = Nothing
    End If
    errMsg = vbNullString
    errMsg = errMsg & "The application encountered the following execution error:" & vbCrLf & vbCrLf
    errMsg = errMsg & Err.Description
    MsgBox errMsg, vbOKOnly + vbCritical, "Error"
    

    
End Sub

Private Sub updateWorksheet(ByRef ws As Excel.Worksheet)
On Error GoTo Error
    Dim rng As Object       '// Excel.Range
    Dim data() As Variant
    Dim totalRows As Long
    Dim totalCols As Long
    Dim i As Long
    Dim Xref As Long
    Dim Yref As Long
    
    data = ws.UsedRange
    Xref = LBound(data, 1)
    Yref = LBound(data, 2)
    ReDim Preserve data(Xref To UBound(data, 1), Yref To UBound(data, 2) + 2)
    totalRows = UBound(data, 1) - Xref
    totalCols = UBound(data, 2) - Yref
    
    data(Xref + 4, Yref + 15) = "Report Date"
    data(Xref + 4, Yref + 16) = "Contractor"
    For i = Xref + 5 To UBound(data, 1)
        data(i, Yref + 15) = "=RIGHT($A$2,6)"
        data(i, Yref + 16) = "=Right($A$3,5"
    Next
    Set rng = ws.Range("A1")
    Set rng = ws.Range(rng, rng.Offset(totalRows, totalCols))
    rng = data
    Set rng = Nothing
Exit Sub



Resume
Error:
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    Err.Raise Err.Number, Err.Source, Err.Description
    

End Sub

Open in new window

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.