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

我得到＆＃34;对象变量或者没有设置块变量＆＃34;上＆＃34; Selection.Delete Shift：= xlUp＆＃34;

如果我对此发表评论，那么我就可以开始使用＃34; ActiveWorkbook.RefreshAll＆＃34;

我通过积极设置活动书来解决这个问题，然后我就开始了＆＃34; .Range（选择，ActiveCell.SpecialCells（xlLastCell））。选择＆＃34;相同的错误块/变量未设置。我在这里不知所措。当我在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上（选择，ActiveCell.SpecialCells（xlLastCell））。选择并且它是相同的未设置错误。

Answer 1

哦 - 我认为你在Set上有错误。

Set XlBook = Xl.Workbooks.Open(MySheetPath)

这会删除工作表上的所有数据，为什么不只是：

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

有很多次，错误并不表示出现了什么问题，特别是在控制一个办公用品时。当您删除该行，并在下一行发生错误时，它清楚地表明它不会导致问题。

Answer 2

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

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

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

2 个答案: