Question

我对VBA完全不熟悉，我需要一些帮助来解决我在Microsoft Office中找到的以下VBA代码（我目前正在使用Excel 2007）。我想知道如何做三件事：

创建一个按钮，在单击时运行代码。
使用活动工作表的名称保存临时工作簿文件，而不是源工作簿的名称。
选择K列中的所有电子邮件地址，并将其作为以下代码中创建的电子邮件的收件人插入。

有人能帮我一把吗？

Sub Mail_ActiveSheet()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook
        ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    ' Determine the Excel version, and file extension and format.
    With Destwb
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered NO in the security dialog."
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
    End With

    ' You can use the following statements to change all cells in the
   ' worksheet to values.
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    ' Save the new workbook, mail, and then delete it.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = " " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")

    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
       ' Change the mail address and subject in the macro before
       ' running the procedure.
        With OutMail
            .To = "laragon2@its.jnj.com"
            .CC = ""
            .BCC = ""
            .Subject = "test"
            .Body = "test"
            .Attachments.Add Destwb.FullName
            .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

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

Answer 1

对于1.您可以在Developer标签 - ＆gt; Controls组 - ＆gt;下创建一个按钮insert，找到一个按钮并为其分配现有的宏。

For 2. Change sourcewb.name - ＆gt; activeSheet.name

对于3.（假设列K，每个单元格在每个单元格中包含一个有效的电子邮件地址）

编辑您可以将以下代码放在以下行之后：

Set Sourcewb = ActiveWorkbook

Dim recipients As String
Dim i As Long
Dim height as long

With ActiveSheet
    .Activate
    Height = .Cells(.Rows.Count, 11).End(xlUp).Row ' column k
    For i = 1 To Height
        If .Cells(i, 11).Value <> "" Then 'if that cell contains ONE email address
            recipients = recipients & ";" & .Cells(i, 11).Value 'append it
        End If

    Next i
    If Len(recipients) > 0 Then 'remove the first dummy ";"
        recipients = Mid(recipients, 2)
    End If


End With

并替换

With OutMail
            .To = "laragon2@its.jnj.com"

通过

With OutMail
            .To = recipients

编辑2 ：To 对于所有.cells(i,11)

，要从.cells(i,7)更改为11

在VBA cells(ROW,COLUMN)中使用语法。

A = 1

B = 2

...

G = 7

K =第11列，依此类推

您也可以使用以下代码替换原始部件

Dim recipients As String
Dim i As Long
Dim height As Long
Dim colNum As Long


With ActiveSheet
    .Activate
    colNum = .Columns("K").Column ' You can replace K to G <~~~~ Changes here
    height = .Cells(.Rows.Count, colNum).End(xlUp).Row   '<~~~~ Changes here
    For i = 1 To height
        If .Cells(i, 11).Value <> "" Then 'if that cell contains ONE email address
            recipients = recipients & ";" & .Cells(i, colNum).Value 'append it   '<~~~~ Changes here
        End If

    Next i
    If Len(recipients) > 0 Then 'remove the first dummy ";"
        recipients = Mid(recipients, 2)
    End If


End With

使用选项卡名称作为VBA的工作簿名称

1 个答案: