我知道这个问题已经讨论过很多次了，但我的问题没有解决。我有一个用于不同项目的 excel 宏。它是用变量编码的，变量是从 MS Access 传递的，因此，这个宏可以用于任何项目。
不仅双击时运行良好，而且它也适用于其他项目。我能想到的唯一让这个项目与众不同的是，在同一个过程中，在几步之前调用了另一个 excel 文件。但运行后，该 excel 实例已关闭（我检查过，它确实关闭了，我将其关闭
SET myexcelinstance = nothing
会是什么？我也可以双击该项目的文件，并且所有内容都创建无误。
但是当从 Ms Access 调用时，它只是像普通文件一样打开
编辑：添加宏
这是在一个单独的模块中
Option Explicit
Public Sub auto_open()
MainProcedure
End Sub
这是主要程序，在一个单独的模块中
Option Explicit
Public x As Integer
Public PadLength As Integer
Public LastRow As Long
Public LastRow4 As Long
Public LastRow2 As Long
Public CurPath As String
Public ProjectName As String
Public FormattedDate As String
Public RunDate As Date
Public ReportPath As String
Public MonthlyPath As String
Public TableName As String
Public FinalExcelFileName As String
Public ExcelFileName As String
Public ExcelSheetName As String
Public ExcelTemplate As String
Public ExcelPasteTo As String
Public TemplateFileName As String
Public SheetToSelect As String
Public FSO
Public oShell As Object
Public iResponse As Integer
Public CurCell, CurRange As Range
Public CurRowNum As Long
Public LastRowOfSection As Long
Public FirstRowOfSection As Long
Public CurLastColumn As Variant
Public CurLastRow As Long
Public CurFileName As String
Public CurSheetName As String
Public Sub MainProcedure()
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Application.EnableEvents = False
CurPath = ActiveWorkbook.Path & "\"
'this is to deselect sheets
Sheets("QFilesToExportEMail").Select
Sheets("QReportDates").Activate
FormattedDate = Range("A2").Value
RunDate = Range("B2").Value
ReportPath = Range("C2").Value
MonthlyPath = Range("D2").Value
ProjectName = Range("E2").Value
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
'Ctrl + Shift + End
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
CurRowNum = 2
Set CurRange = Sheets("QFilesToExportEMail").Range("B" & CurRowNum & ":B" & LastRow) '''''sets the range to use
For Each CurCell In CurRange ''''checks each cell in range
If CurCell <> "" Then '''''will only do something if the cell is not blank
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
ExcelFileName = Range("B" & CurRowNum).Value
FinalExcelFileName = Range("B" & CurRowNum).Value
LastRowOfSection = Sheets("QFilesToExportEMail").Range("B" & CurRowNum & ":B" & LastRow).Find(what:=ExcelFileName, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
'FirstRowOfSection = Sheets("QFilesToExportEMail").Range("B" & CurRowNum & ":B" & LastRow).Find(what:=ExcelFileName).Row
TemplateFileName = Range("F" & CurRowNum).Value
FirstRowOfSection = ActiveWorkbook.Worksheets("QFilesToExportEMail").Columns(2).Find(ExcelFileName).Row
TableName = Range("A" & CurRowNum).Value
ExcelSheetName = Range("C" & CurRowNum).Value
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
If CurRowNum = FirstRowOfSection Then
SheetToSelect = ExcelSheetName
End If
If IsNull(TemplateFileName) Or TemplateFileName = "" Then
Workbooks.Add
Else
Workbooks.Open CurPath & TemplateFileName
End If
ActiveWorkbook.SaveAs MonthlyPath & FinalExcelFileName
For i = CurRowNum To LastRowOfSection
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
TableName = Range("A" & i).Value
ExcelSheetName = Range("C" & i).Value
ExcelTemplate = Range("D" & i).Value
ExcelPasteTo = Range("E" & i).Value
If ExcelSheetName = "" Then
ExcelSheetName = TableName
End If
If ExcelTemplate = "format" Then
Windows(FinalExcelFileName).Activate
ActiveWorkbook.Sheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = ExcelSheetName
Windows(ProjectName & ".xlsm").Activate
Sheets(TableName).Select
CurLastColumn = MyColumnLetter(Range("A1").CurrentRegion.Columns.Count)
CurLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:" & CurLastColumn & CurLastRow).Select
Selection.Copy
Windows(FinalExcelFileName).Activate
Sheets(ExcelSheetName).Select
Range(ExcelPasteTo).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
FormatBasics
ElseIf ExcelTemplate = "" Then
Windows(ProjectName & ".xlsm").Activate
Sheets(TableName).Select
CurLastColumn = MyColumnLetter(Range("A1").CurrentRegion.Columns.Count)
CurLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:" & CurLastColumn & CurLastRow).Select
Selection.Copy
Windows(FinalExcelFileName).Activate
Sheets(ExcelSheetName).Select
Range(ExcelPasteTo).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
' Dim SearchString As String
' Dim SearchRange As Range, cl As Range
' Dim FirstFound As String
' Dim sh As Worksheet
'
' ' Set Search value
' SearchString = "N/A"
' Application.FindFormat.Clear
' ' loop through all sheets
' For Each sh In ActiveWorkbook.Worksheets
' ' Find first instance on sheet
' Set cl = sh.Cells.Find(What:=SearchString, _
' After:=sh.Cells(1, 1), _
' LookIn:=xlValues, _
' LookAt:=xlPart, _
' SearchOrder:=xlByRows, _
' SearchDirection:=xlNext, _
' MatchCase:=False, _
' SearchFormat:=False)
' If Not cl Is Nothing Then
' ' if found, remember location
' FirstFound = cl.Address
' ' format found cell
' Do
' cl.Font = "Calibri"
' cl.Interior.ColorIndex = 3
' ' find next instance
' Set cl = sh.Cells.FindNext(After:=cl)
' ' repeat until back where we started
' Loop Until FirstFound = cl.Address
' End If
' Next
ElseIf ExcelTemplate Like "*TEMPLATE*" Then
Windows(ProjectName & ".xlsm").Activate
Sheets(ExcelTemplate).Copy after:=Workbooks(FinalExcelFileName).Sheets(1)
ActiveSheet.Name = ExcelSheetName
ActiveSheet.Move after:=Worksheets(Worksheets.Count) 'moves it to the end
Sheets(ExcelSheetName).Select
Windows(ProjectName & ".xlsm").Activate
Sheets(TableName).Select
CurLastColumn = MyColumnLetter(Range("A1").CurrentRegion.Columns.Count)
CurLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:" & CurLastColumn & CurLastRow).Select
Selection.Copy
Windows(FinalExcelFileName).Activate
Sheets(ExcelSheetName).Select
Range(ExcelPasteTo).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range(ExcelPasteTo).Select
Next i
If LastRowOfSection < LastRow Then
CurRowNum = LastRowOfSection + 1
Else
CurRowNum = LastRowOfSection
End If
End If
Windows(FinalExcelFileName).Activate
If CheckSheet("Sheet1") Then
Sheets("Sheet1").Delete
End If
Sheets(SheetToSelect).Select
ActiveWorkbook.Save
ActiveWorkbook.Close
If LastRowOfSection >= LastRow Then
Exit For
End If
Next
CurSheetName = ""
Windows(ProjectName & ".xlsm").Activate
Sheets("QFilesToExportEMail").Select
'Ctrl + Shift + End
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set CurRange = Sheets("QFilesToExportEMail").Range("A2:A" & LastRow) '''''sets the range to use
For Each CurCell In CurRange ''''checks each cell in range
If CurCell <> "" Then '''''will only do something if the cell is not blank
CurSheetName = CurCell
If CheckSheet(CurSheetName) Then
Sheets(CurSheetName).Delete
End If
End If
Next
Sheets("QFilesToExportEMail").Delete
Sheets("QReportDates").Delete
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Function CheckSheet(ByVal sCurSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In ActiveWorkbook.Sheets
If oSheet.Name = sCurSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
Public Function MyColumnLetter(MyNumber As Long) As String
If MyNumber > 26 Then
MyColumnLetter = Chr(Int((MyNumber - 1) / 26) + 64) & Chr(((MyNumber - 1) Mod 26) + 65)
Else
MyColumnLetter = Chr(MyNumber + 64)
End If
End Function
Public Function xlLastCol(Optional WorkCurSheetName As String) As Long 'finds the last populated col in a worksheet
If WorkCurSheetName = vbNullString Then WorkCurSheetName = ActiveSheet.Name
With Worksheets(WorkCurSheetName)
On Error Resume Next
xlLastCol = .Cells.Find("*", .Cells(1), xlFormulas, xlWhole, xlByColumns, xlPrevious).Column
If Err <> 0 Then xlLastCol = 0
End With
End Function
Public Function QueryDB(ByVal connectionString As String, ByVal Target As Excel.Range, ByVal SQL As String)
Dim qt As Excel.QueryTable
Dim ws As Excel.Worksheet
Set ws = Target.Parent
Set qt = ws.QueryTables.Add(connectionString, Target, SQL)
qt.Refresh BackgroundQuery:=False
End Function
'=====================================================================
'The following function will left pad a string with a specified
'character. It accepts a base string which is to be left padded with
'characters, a character to be used as the pad character, and a
'length which specifies the total length of the padded result.
'=====================================================================
Function Lpad(MyValue$, MyPadCharacter$, MyPaddedLength%)
PadLength = MyPaddedLength - Len(MyValue)
Dim PadString As String
For x = 1 To PadLength
PadString = PadString & MyPadCharacter
Next
Lpad = PadString + MyValue
End Function
'=====================================================================
'The following function will right pad a string with a specified
'character. It accepts a base string which is to be right padded with
'characters, a character to be used as the pad character, and a
'length which specifies the total length of the padded result.
'=====================================================================
Function Rpad(MyValue$, MyPadCharacter$, MyPaddedLength%)
PadLength = MyPaddedLength - Len(MyValue)
Dim PadString As String
For x = 1 To PadLength
PadString = MyPadCharacter & PadString
Next
Rpad = MyValue + PadString
End Function
Public Function FormatBasics()
Dim x As Long
Dim FormatColumnLetter, FormatColumnName As String
Application.EnableCancelKey = xlDisabled
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("A1:" & MyColumnLetter(xlLastCol) & "1").Select
Selection.Font.Bold = True
With Selection.Interior
.PatternColorIndex = 2
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Selection.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
For x = 1 To xlLastCol
FormatColumnLetter = MyColumnLetter(x)
FormatColumnName = StrConv(Range(FormatColumnLetter & "1").Value, vbLowerCase)
Range(FormatColumnLetter & "1").Value = StrConv(Range(FormatColumnLetter & "1").Value, vbProperCase)
If FormatColumnName = "factypedesc" Then
Range(FormatColumnLetter & "1").Value = "FacTypeDesc"
ElseIf FormatColumnName = "facsubtypedesc" Then
Range(FormatColumnLetter & "1").Value = "FacSubTypeDesc"
ElseIf FormatColumnName = "facsubtype" Then
Range(FormatColumnLetter & "1").Value = "FacSubType"
ElseIf FormatColumnName = "mpinetworkcode" Then
Range(FormatColumnLetter & "1").Value = "Network"
ElseIf FormatColumnName = "mpicontractid" Then
Range(FormatColumnLetter & "1").Value = "ContractNumber"
ElseIf FormatColumnName = "dob" Or FormatColumnName = "dateofbirth" Then
Range(FormatColumnLetter & "1").Value = "DOB"
ElseIf FormatColumnName = "deanumber" Then
Range(FormatColumnLetter & "1").Value = "DEANumber"
End If
Next x
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:" & MyColumnLetter(xlLastCol)).Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
Range("A2").Select
End Function