(Solved) – My access VBA code for creating excel files with data connections works on the first file then always fails at random points

  • by
(solved)-–-my-access-vba-code-for-creating-excel-files-with-data-connections-works-on-the-first-file-then-always-fails-at-random-points

I have written some code in Access to copy an excel template file, perform some refresh and simple transsformations on the copy, save, and then move to the next file. Initially i could create multiple files by looping through a list but kept getting odd errors on random lines during subsequent iterations. I’ve avoided Active anything as that seems to be problematic, but still the code fails on the second iteration. Mostly its on the Connection.Refresh but sometimes it is other lines such as “Method Rows of object Global failed”. I’m fairly experienced on this. I also tried setting all my vba excel objects to nothing at the end of each loop but that didnt help. Code below. Any ideas gratefully recieved:

Sub CreateFilesIndividual()

Dim mw As Variant
Dim ccount As Integer
Dim rs As Recordset
Dim i As Integer

Set rs = CurrentDb.OpenRecordset("SELECT CM1920 as CM from Comm1920 order by rscount desc", dbOpenSnapshot)
If rs.RecordCount = 0 Then
    MsgBox "No Commissioners Codes available - exiting"
    Exit Sub
End If

For i = 1 To rs.RecordCount
    CreateFile rs("CM")
Next

End Sub

Sub CreateFile(commCode)

Dim templateloc As String
Dim fileloc As String
Dim Xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim ws2 As Excel.Worksheet
Dim ws3 As Excel.Worksheet
Dim ws4 As Excel.Worksheet

templateloc = "\gstt.localUsers1MWaringDocumentsBespoke Report RequestsContracts automationProposal template CCGs 2021 v2.6.xlsm"
fileloc = "\gstt.localUsers1MWaringDocumentsBespoke Report RequestsContracts automationtestProposal CCGs 1920 v2.6 " & commCode & ".xlsm"

FileCopy templateloc, fileloc
    '
    Set Xl = CreateObject("Excel.Application")
    Set wb = Xl.Workbooks.Open(fileloc)
    Set ws = wb.Sheets("Commissioner Summary")
    ws.Unprotect
    ws.Cells(2, 4) = commCode.Value
    Debug.Print ws.Cells(2, 4).Value & " - " & commCode.Value
    wb.Connections("Update1").Refresh
    Set ws2 = wb.Sheets("Contract Category Detail")
    ws2.Range("A:AM").Copy

    Set ws3 = wb.Sheets("CC detail")
    ws3.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    ws3.Range("A1").PasteSpecial Paste:=xlPasteFormats
    ws3.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

    ws3.Range("AG3").FormulaR1C1 = "=ROUND(RC[-2] RC[-1],0)"
    Dim myrange As Integer
    myrange = ws3.Range("A" & Rows.Count).End(xlUp).Row
    ws3.Range("AG3:AG" & myrange).FillDown

    ws3.Range("AL3").FormulaR1C1 = "=RC[-5]*RC34"
    ws3.Range("AL3:AL" & myrange).FillDown
    ws3.Range("A:AM").Copy

    Set ws4 = wb.Sheets("Contract_Category_detail")
    ws4.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    ws4.Range("A1").PasteSpecial Paste:=xlPasteFormats
    ws4.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

    ws2.Delete
    ws3.Delete

    wb.Save
    wb.Close

    'Clean up
    Xl.Quit
    Set ws = Nothing
    Set ws2 = Nothing
    Set ws3 = Nothing
    Set ws4 = Nothing
    Set wb = Nothing
    Set Xl = Nothing

End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *