Использование имени вкладки в качестве имени книги с VBA

Question

Я совершенно не знаком с VBA, и мне нужна помощь со следующим кодом VBA, который я нашел в Microsoft Office (в настоящее время я использую 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 

Answer 1

Для 1. Вы можете создать кнопку под Developer Tab ->Controls Group ->insert, найти кнопку и назначить существующий макрос к нему.

Для 2. Изменения sourcewb.name ->activeSheet.name

Для 3. (Предполагая, что столбец K, каждая ячейка содержит один действительный адрес электронной почты, в каждой ячейке)

EDIT Вы можете поместить этот код после линия:

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 

EDIT 2: Для того, чтобы изменить от .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