0
答：设置XlBook = Xl.Workbooks.Open（MySheetPath）Excel的VBA从MS Access宏 - 对象变量或与块变量未设置
我试图解决别人的宏。他们在Access数据库中有一些影响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移：= xlUp”
如果我评论说出来我再得到它“ActiveWorkbook.RefreshAll” （选择，ActiveCell.SpecialCells（xlLastCell））。选择“相同的错误块/变量未设置”。选择“相同的错误块/变量未设置”。我只是在这里亏本。当我在宏的宏记录器相同类型的宏工作，但来自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）），选择和它是一样的没有设置错误。
我改变了，并收到一个新的错误。往上看。 – 2014-09-22 18:06:12
将设置更改为编辑答案。 – 2014-09-22 18:15:03