Update Excel Sheet from Access

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?

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.

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

Select allOpen 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.

Runtime error 1004 on line:

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

Compile error

Replace the parameter type from Excel.worksheet to Object ...

compile error

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

Select allOpen in new window

Common sens .......

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

ok, my apologies: the procedure updateWorkbook don't need parameters.

I don't follow

Compile error

Public Sub updateWorkbook() instead of Public Sub updateWorkbook(ByVal path As String)

Error

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.

The only issue is that  #NA is written out to Column R






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

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

Select allOpen in new window