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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Dale FyeOwner, Developing Solutions LLCCommented:
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
Dale FyeOwner, Developing Solutions LLCCommented:
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
10 Tips to Protect Your Business from Ransomware

Did you know that ransomware is the most widespread, destructive malware in the world today? It accounts for 39% of all security breaches, with ransomware gangsters projected to make $11.5B in profits from online extortion by 2019.

shieldscoAuthor Commented:
Runtime error 1004 on line:

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

Error
0
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
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
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.