时间戳

首页 > 解决方案 > 我用于创建具有数据连接的 excel 文件的访问 VBA 代码适用于第一个文件，然后总是在随机点失败

excel - 我用于创建具有数据连接的 excel 文件的访问 VBA 代码适用于第一个文件，然后总是在随机点失败

问题描述

我在 Access 中编写了一些代码来复制一个 excel 模板文件，对复制的内容执行一些刷新和简单的转换，保存，然后移动到下一个文件。最初，我可以通过循环遍历列表来创建多个文件，但在随后的迭代中不断在随机行上出现奇怪的错误。我已经避免了 Active 任​​何东西，因为这似乎是有问题的，但代码在第二次迭代中仍然失败。主要是在 Connection.Refresh 上，但有时是其他行，例如“对象全局的方法行失败”。我在这方面相当有经验。我还尝试在每个循环结束时将所有 vba excel 对象设置为空，但这没有帮助。代码如下。感激地收到任何想法：

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.local\Users\01\MWaring\Documents\Bespoke Report Requests\Contracts automation\Proposal template CCGs 2021 v2.6.xlsm"
     fileloc = "\\gstt.local\Users\01\MWaring\Documents\Bespoke Report Requests\Contracts automation\test\Proposal 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

标签： excelvbams-accessconnection

解决方案

当我从 Access 使用 Excel 执行大量复制粘贴操作时，我想我遇到了一个奇怪的错误（可能相同）。比我创建了一个函数 ClearClipboard() 在所有这些操作之后我调用它。这里是：

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function

试试看。我希望它有所帮助。

推荐阅读