MS Access 中的 Excel VBA 宏 - 对象变量或未设置块变量

Question

答案：设置 XlBook = Xl.Workbooks.Open(MySheetPath)

我正在尝试解决其他人的宏。它们在 Access DB 中有一些影响 Excel 工作簿的宏。

有两段代码有问题。

XlBook.Sheets("Item Detail Frozen").Select
Set XlSheet = XlBook.Worksheets("Item Detail Frozen")
With XlSheet
   XlSheet.Cells.Select
   XlSheet.Range("A1").Activate
   Selection.Delete Shift:=xlUp

End With

XlBook.Sheets("Item Detail").Select
Set XlSheet = XlBook.Worksheets("Item Detail")
With XlSheet
    Xl.WindowState = xlMinimized
    ActiveWorkbook.RefreshAll
    .Range("A1:D1").Select
    .Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
End With

我得到“对象变量或未设置块变量” "Selection.Delete Shift:=xlUp"

如果我把它注释掉，我就会在“ActiveWorkbook.RefreshAll”上得到它

我通过主动设置活动书来解决这个问题，然后我开始使用它 ".Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select" 未设置相同的错误块/变量。我只是在这里不知所措。当我在 excel 中做宏记录器时，相同类型的宏可以工作，但是当来自 Access 时，它不喜欢它。

这是完整的代码。

    Option Compare Database
    Option Explicit

    Function FileExists(ByVal FileToTest As String) As Boolean
       FileExists = (Dir(FileToTest) <> "")
    End Function
    Sub DeleteFile(ByVal FileToDelete As String)

    DeleteFile:

       If FileExists(FileToDelete) Then 'See above
          On Error GoTo DeleteFile_ErrorHandler
          Kill FileToDelete
       End If
       Exit Sub
    DeleteFile_ErrorHandler:
       On Error Resume Next
       MsgBox "There was an error deleteing the file(s), " & FileToDelete & _
              ".  Check to see if you or any one has any of these files open and have them closed; then press OK.  "

    End Sub



    Public Function PrepareOutputFile() As Variant
        'Variables to refer to Excel and Objects
        Dim MySheetPath As String
        Dim Xl As Excel.Application
        Dim XlBook As Excel.Workbook
        Dim XlSheet As Excel.Worksheet
        Dim NewFilePath As String
        Dim NewPathDir As String
        Dim LastSlashPos      As String
        Dim AttachmentDir      As String
        Dim NewFileWildCard      As String
        Dim NewFileName As String


        ' Tell it location of actual Excel file
        MySheetPath = "W:\Sams-LibertySport\Sams-LibertySport- Week #x - as of mm-dd-yyyy.xls"

        'Open Excel and the workbook
        Set Xl = CreateObject("Excel.Application")
        Set XlBook = GetObject(MySheetPath)

        'Make sure excel is visible on the screen
        Xl.Visible = True
        XlBook.Windows(1).Visible = True

        XlBook.Sheets("Item Detail Frozen").Select
        Set XlSheet = XlBook.Worksheets("Item Detail Frozen")
        'With XlSheet

         '   .Cells.Select
          '  .Range("A1:D1").Activate
           ' Selection.Delete Shift:=xlUp

        'End With
        With XlSheet
           XlSheet.Cells.Select
           XlSheet.Range("A1").Activate
           Selection.Delete Shift:=xlUp

        End With

        XlBook.Sheets("Item Detail").Select
        Set XlSheet = XlBook.Worksheets("Item Detail")
        With XlSheet
            Xl.WindowState = xlMinimized
            ActiveWorkbook.RefreshAll
            .Range("A1:D1").Select
            .Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
            Selection.Copy
        End With

        XlBook.Sheets("Item Detail Frozen").Select
        Set XlSheet = XlBook.Worksheets("Item Detail Frozen")
        With XlSheet

            .Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            .Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            .Cells.Select
            .Cells.EntireColumn.AutoFit
            Xl.CutCopyMode = False
            ChDir "W:\"
            NewFilePath = Replace(Replace(Replace(MySheetPath, "W:\", "R:\"), _
                           "#x", "#" & CInt(Right(DLookup("EndingWmWeek", "Period", "PeriodCode='LW'"), 2))), _
                          "mm-dd-yyyy", Format(DLookup("[As-of Date]", "As-of Date"), "mm-dd-yyyy"))
            LastSlashPos = InStrRev(NewFilePath, "\")
            AttachmentDir = Left(NewFilePath, LastSlashPos - 1) & "\EmailAttachments"
            NewFileWildCard = Mid(NewFilePath, LastSlashPos + 1, InStr(LastSlashPos, NewFilePath, "-", vbTextCompare) - LastSlashPos) & "*.*"
            NewFileName = Mid(NewFilePath, LastSlashPos + 1, Len(NewFilePath) - LastSlashPos)


            While FileExists(NewFilePath)
                DeleteFile NewFilePath
            Wend
            ActiveWorkbook.SaveAs FileName:= _
                NewFilePath, FileFormat:= _
                xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                , CreateBackup:=False

        End With
        XlBook.Sheets("TopLine Overview").Select
        Set XlSheet = XlBook.Worksheets("TopLine Overview")
        XlSheet.Range("A1").Select
        XlSheet.Range("A1").Activate
        ActiveWorkbook.Save

        'Clean up and end with worksheet visible on the screen
        ActiveWorkbook.Close (False) 'Discard changes
        Set XlSheet = Nothing
        Set XlBook = Nothing
        Xl.Quit
        Set Xl = Nothing

        While FileExists(AttachmentDir & "\" & NewFileWildCard)
            DeleteFile AttachmentDir & "\" & NewFileWildCard
        Wend
        FileCopy NewFilePath, AttachmentDir & "\" & NewFileName

    End Function


    Public Sub PrepareDownloadedMdbFiles()

        'Variables to refer to Excel and Objects
        Dim MyDBPath As String
        Dim Db As Database
        Dim NewDBName As String

        Dim fdr As String
        Dim filenames() As String
        Dim FileIndex As Integer
        Dim fileCount As Integer
        FileIndex = 0

        filenames = GetFileNames("W:\lib394a_*.mdb")
        For FileIndex = 0 To UBound(filenames) - 1

            fdr = filenames(FileIndex)
            'Open Database
            Set Db = Workspaces(0).OpenDatabase("W:\" & fdr)
            Dim td As TableDef
            NewDBName = ""
            For Each td In Db.TableDefs
                If Left(td.Name, 4) <> "Msys" Then
                    NewDBName = td.Name
                End If
            Next td
            Db.Close

            If NewDBName <> "" Then

                DeleteFile "W:\" & NewDBName & ".mdb"
                Name "W:\" & fdr As "W:\" & NewDBName & ".mdb"

            End If
        Next FileIndex


    End Sub

    Public Function GetFileNames(Template As String) As String()

        'Given a FileName template such as W:\ab*.*, return an array of filenames

        Dim MyDBPath As String
        Dim Db As Database
        Dim NewDBName As String

        Dim fdr As String
        Dim filenames() As String
        Dim FileIndex As Integer
        Dim fileCount As Integer
        FileIndex = 0
        ReDim filenames(0)

        fdr = Dir(Template)
        Do While fdr <> ""
            ReDim Preserve filenames(FileIndex + 1)
            filenames(FileIndex) = fdr
            FileIndex = FileIndex + 1
            fdr = Dir()
        Loop

        GetFileNames = filenames

    End Function

我现在改成

XlBook.Sheets("Item Detail Frozen").Select
Set XlSheet = XlBook.Worksheets("Item Detail Frozen")

XlSheet.Cells.Clear

XlBook.Sheets("Item Detail").Select
Set XlSheet = XlBook.Worksheets("Item Detail")
With XlSheet
    Xl.WindowState = xlMinimized
    XlBook.RefreshAll
    XlSheet.Range("A1:D1").Select
    XlSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
End With

现在错误出现在 XlSheet.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select 和未设置错误相同。

Answer 1

哦- 我认为你在 Set 上遇到了错误。

Set XlBook = Xl.Workbooks.Open(MySheetPath)

这会删除工作表上的所有数据，所以为什么不直接删除：

Worksheets(("Item Detail Frozen").Cells.Clear

很多时候，错误并不能说明哪里出了问题，尤其是在从另一个办公产品控制一个办公产品时。当您删除该行并且下一行发生错误时，这清楚地表明它不是导致问题的原因。

Answer 2

保留所有原始代码但修复 设置 XlBook = Xl.Workbooks.Open(MySheetPath)

修复了所有错误。似乎使用另一种打开 excel 文件的方法并不是最理想的。谢谢您的帮助。