使用VBA从MS Access编辑Excel文件遇运行错误及卡顿求助

问题描述 #

我有一个MS Access数据库，需要将查询结果导出为Excel文件的工作表，后续完成以下操作：打开新生成的Excel文件，应用条件格式，保存并关闭文件，最后创建以当日日期命名的文件夹并将Excel文件移入其中。

使用以下代码时出现运行时错误'75'（路径/文件访问错误），有时还会在格式设置过程中卡住。条件格式代码来自宏录制，求帮助。

原代码 #

DoCmd.TransferSpreadsheet acExport, 10, "query1", _
"C:\Archive\MyFile " & Format(Date, "mm-DD-yy") & ".xlsx", True, "MySheet1"
DoCmd.TransferSpreadsheet acExport, 10, "query2", _
"C:\Archive\MyFile " & Format(Date, "mm-DD-yy") & ".xlsx", True, "MySheet2"
Call createFolder

Dim xlApp As Object 'Excel.Application
Dim xlWB As Object  'Excel.Workbook
Dim xlSh As Object  'Excel.Worksheet

Set xlApp = CreateObject("Excel.Application")   'New Excel.Application
Set xlWB = xlApp.Workbooks.Open("c:\Archive\MyFile " & Format(Date, "mm-DD-yy") & ".xlsx")
Set xlSh = xlWB.Sheets("MySheet1")

xlApp.Visible = True
    
Set xlWB = ActiveWorkbook
   'What follows is code from recording a macro to format a date column with red
    Sheets("MySheet1").Select
Selection.AutoFilter
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0
.PatternTintAndShade = 0
 End With
 With Selection.Font
 .ThemeColor = xlThemeColorDark1
 .TintAndShade = 0
 End With
 ActiveWindow.LargeScroll ToRight:=-1
 Range("H2").Select
 Range(Selection, Selection.End(xlDown)).Select
 Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
 "=AND(LEN(H2)>0,TODAY()-H2>=15)"
 Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
 With Selection.FormatConditions(1).Font
 .ThemeColor = xlThemeColorDark1
 .TintAndShade = 0
 End With
 With Selection.FormatConditions(1).Interior
 .PatternColorIndex = xlAutomatic
 .Color = 255
 .TintAndShade = 0
  End With
  Selection.FormatConditions(1).StopIfTrue = False
Range("A2").Select
'the close the book
Close Workbook
 'move today's file to folder with today's date
 Dim sfolder As String
 Dim dfloder As String

 sfolder = "c:\Archive\"
 dfolder = "c:\Archive\" & Format(Date, "mm-DD-yy") & "\"
 Name sfolder & "MyFile " & Format(Date, "mm-DD-yy") & ".xlsx" As dfolder & "prefix " & Format(Date, "mm-DD-yyyy") & ".xlsx"
 End function
 
Public Sub createFolder()

    'Create the subfolders with today's date
    If Len(Dir("c:\\Archive\" & Format(Date, "mm-DD-yy"), vbDirectory)) = o Then
    MkDir "c:\Archive\" & Format(Date, "mm-DD-yy")
    Else
    MsgBox ("folder with today's date already exists. Plesae check.")
 
    End If

End Sub

错误原因及修复方案 #

1. 路径/文件访问错误（错误75） #

• 文件夹创建逻辑错误：Dir("c:\\Archive\" & ...)多了一个反斜杠，且判断条件用了字母o而非数字0，导致文件夹创建失败或误判。
• 文件占用未释放：未正确关闭Excel工作簿和退出Excel进程，导致文件被锁定，无法移动。
• 变量名拼写错误：dfloder应为dfolder。

2. 格式设置卡顿 #

• 宏录制生成的代码大量使用Select和Selection，这类操作效率低且易导致卡顿，应直接操作Excel对象。
• 后期绑定（CreateObject）下未定义Excel常量（如xlSolid），需手动定义对应数值避免错误。

修复后的完整代码 #

' 定义Excel常量（后期绑定需手动定义）
Const xlSolid As Long = 1
Const xlAutomatic As Long = -4105
Const xlThemeColorLight2 As Long = 4
Const xlThemeColorDark1 As Long = 1
Const xlExpression As Long = 2

Sub ExportAndFormatExcel()
    Dim excelPath As String
    Dim dateFolder As String
    Dim newFileName As String
    
    ' 定义文件和文件夹路径
    excelPath = "C:\Archive\MyFile " & Format(Date, "mm-DD-yy") & ".xlsx"
    dateFolder = "C:\Archive\" & Format(Date, "mm-DD-yy") & "\"
    newFileName = dateFolder & "prefix " & Format(Date, "mm-DD-yyyy") & ".xlsx"
    
    ' 导出查询到Excel
    DoCmd.TransferSpreadsheet acExport, 10, "query1", excelPath, True, "MySheet1"
    DoCmd.TransferSpreadsheet acExport, 10, "query2", excelPath, True, "MySheet2"
    
    ' 创建日期文件夹
    createFolder dateFolder
    
    ' 初始化Excel对象
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSh As Object
    Dim headerRange As Object
    Dim dateRange As Object
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ' 后台运行，避免卡顿
    Set xlWB = xlApp.Workbooks.Open(excelPath)
    Set xlSh = xlWB.Sheets("MySheet1")
    
    ' 应用格式（无Select操作）
    ' 自动筛选
    xlSh.AutoFilterMode = False
    xlSh.Range("A1").AutoFilter
    
    ' 冻结窗格
    xlApp.ActiveWindow.SplitRow = 1
    xlApp.ActiveWindow.FreezePanes = True
    
    ' 列宽自适应
    xlSh.Cells.EntireColumn.AutoFit
    
    ' 设置表头格式
    Set headerRange = xlSh.Range(xlSh.Range("A1"), xlSh.Range("A1").End(xlToRight))
    With headerRange.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With headerRange.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    
    ' 设置H列日期条件格式
    Set dateRange = xlSh.Range(xlSh.Range("H2"), xlSh.Range("H2").End(xlDown))
    With dateRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(LEN(H2)>0,TODAY()-H2>=15)")
        .SetFirstPriority
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        With .Interior
            .PatternColorIndex = xlAutomatic
            .Color = 255
            .TintAndShade = 0
        End With
        .StopIfTrue = False
    End With
    
    ' 保存并关闭Excel
    xlWB.Save
    xlWB.Close SaveChanges:=False
    xlApp.Quit
    
    ' 释放对象
    Set dateRange = Nothing
    Set headerRange = Nothing
    Set xlSh = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    
    ' 移动文件到日期文件夹
    Name excelPath As newFileName
End Sub

Public Sub createFolder(folderPath As String)
    ' 创建文件夹（处理路径末尾的反斜杠）
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' 判断文件夹是否存在
    If Len(Dir(folderPath, vbDirectory)) = 0 Then
        MkDir folderPath
    Else
        MsgBox "当日日期的文件夹已存在，请检查。"
    End If
End Sub

关键修复说明 #

• 移除Select操作：直接通过xlSh、headerRange等对象操作，提升效率并避免卡顿。
• 正确释放Excel资源：保存关闭工作簿后退出Excel，释放文件锁，确保能正常移动文件。
• 修正文件夹创建逻辑：修复路径拼写错误和判断条件，确保文件夹正确创建。
• 定义Excel常量：后期绑定模式下手动定义所需常量，避免因未引用Excel库导致的错误。
• 后台运行Excel：设置xlApp.Visible = False，减少界面交互带来的卡顿。

内容的提问来源于stack exchange，提问作者Ezy