0

我对 VBA 完全陌生，我需要一些关于我在 Microsoft Office 中找到的以下 VBA 代码的帮助（我目前使用的是 Excel 2007）。我想知道如何做三件事：

  1. 创建一个在单击时运行代码的按钮。
  2. 使用活动工作表的名称保存临时工作簿文件，而不是源工作簿的名称。
  3. 选择 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
4

1 回答 1

2

对于 1. 您可以在DeveloperTab--> ControlsGroup -->下创建一个按钮insert，找到一个按钮并将现有宏分配给它。

对于 2. 改变sourcewb.name-->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)to更改.cells(i,7)为所有11

在 VBAcells(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
于 2013-02-01T03:15:37.847 回答