Question

我有一张120多张工作簿，其首页有一个很好的功能来提取指定的工作表，将其保存为一本包含大量详细信息的新书。一切正常。尝试添加新功能。在提取的工作表上，我添加了一个按钮，并创建了一个宏，用于通过电子邮件发送完成的文章。问题是，宏的位置引用保持默认返回到原始书源，而不是表单本身（它的所有.XLSM文件）。宏本身就在每张纸上，但我找不到将宏的参考固定到纸张上的方法。我的google-fu让我失望了。任何意见或智慧的话都会非常感激！

好的，这是邮件宏：

Sub Mail_FinishedSheet_Array()

    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim SigString As String
    Dim Signature As String
    Dim StrBody As String

    Set wb1 = ActiveWorkbook
    If Val(Application.Version) >= 12 Then
        If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
            MsgBox "There is VBA code in this xlsx file. There will" & vbNewLine & _
                   "be no VBA code in the file you send. Save the" & vbNewLine & _
                   "file as a macro-enabled (. Xlsm) and then retry the macro.", vbInformation
            Exit Sub
        End If
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Signature details with path
    SigString = Environ("appdata") & _
            "\Microsoft\Signatures\Zonal2014HO.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    ' Make a copy of the file.
    ' If you want to change the file name then change only TempFileName variable.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = wb1.Name & " " & Format(Now, "dd-mmm-yy hh-mm")
    FileExtStr = "." & LCase(Right(wb1.Name, _
                                   Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    'Body contents for HTML format e-mail
    StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Hi," _
    & "<p>Please find a completed checksheet attached for a PC Rebuild." _
    & "<p>Regards, " _
    & "<p></BODY>"

   ' Change the mail address and subject in the macro before you run this procedure.
    With OutMail
        .To = "Eng_Tech_support@zonal.co.uk"
        .CC = "rob.brown@zonal.co.uk"
        .BCC = ""
        .Subject = "Completed PC Rebuild Checksheet " & Format(Now, "dd-mmm-yy")
        .HTMLbody = StrBody & Signature
        .Attachments.Add wb2.FullName
        ' You can add other files by uncommenting the following line.
        '.Attachments.Add ("C:\test.txt")
        ' In place of the following statement, you can use ".Display" to
        ' display the mail.
        .Display
    End With
    On Error GoTo 0

    wb2.Close SaveChanges:=False

    ' Delete the file.
    ' Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

这里是主页面中的提取宏，它将书中的欲望表分开并将其保存为新文件：

Sub Full_Extract()

Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook

'sets site and engineer details into the estate page that is being extracted
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Worksheets(Sheet1.CmbSheet.Value).Range("B4").Value = Worksheets("front page").Range("F8")
Worksheets(Sheet1.CmbSheet.Value).Range("D4").Value = Worksheets("front page").Range("K8")

' copies sheet name from combo box into new document, saves it with site name and current date
' into C:\Temp\ folder for ease of access

    With ActiveWorkbook.Sheets(Array((Sheet1.CmbSheet.Value), "Z-MISC"))
            .Copy
            ActiveWorkbook.SaveAs _
            "C:\temp\" _
            & ActiveWorkbook.Sheets(Sheet1.CmbSheet.Value).Cells(3, 2).Text _
            & " " _
            & Format(Now(), "DD-MM-YY") _
            & ".xlsm", _
            xlOpenXMLWorkbookMacroEnabled, , , , False
        End With

'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub

Answer 1

使用ActiveX按钮

要求其关联的代码位于其所在的工作表中，并且在.Copy和ActiveWorkbook.SaveAs ...语句之后将指向新创建的工作簿中的工作表

如果你想让它独立于＆＃34; Checkbook.xlsm＆＃34;，那么

Mail_FinishedSheet_Array() Sub也必须在新工作簿中。在这种情况下，Sub必须位于两个工作表中的一个（Sheet1.CmbSheet.Value或＆＃34; Z-MISC＆＃34;）被复制到新工作簿中

Answer 2

user3598756钉它。使用ActiveX按钮，然后直接为其指定宏（右键单击，查看代码）已经完美地运行。

excel中定义的宏位置

2 个答案: