VBA에서 탭 이름을 통합 문서 이름으로 사용

Question

저는 VBA를 처음 사용하기 때문에 Microsoft Office에서 찾은 다음 VBA 코드에 대한 도움이 필요합니다. 현재 Excel 2007을 사용하고 있습니다. 세 가지 방법을 알고 싶습니다.

1. 클릭하면 코드가 실행되는 버튼을 만듭니다.
2. 활성 통합 문서 이름이 아닌 워크 시트 이름이 인 임시 통합 문서 파일을 저장합니다.
3. K 열의 모든 이메일 주소를 선택하고 아래 코드에서 생성 된 이메일의 수신자로 입력하십시오.

누군가 내게 이것을 줄 수 있습니까? >insert 버튼을 찾아 그것에 매크로를 기존에 할당 ->Controls 그룹 -

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 탭 아래 버튼을 만들 수 있습니다. 당신은 후 아래 코드를 넣을 수 있습니다>activeSheet.name

3.를 들어 (가정 열 K, 각 셀은 각 셀에 하나 개의 유효한 이메일 주소를 포함)

편집 -이

sourcewb.name 2. 변경의 경우 라인 :

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 

012 3,516,

그리고

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

2 EDIT

With OutMail 
      .To = recipients 

으로 바꾸 대한 모든 VBA에서 11

cells(ROW,COLUMN) 구 사용에 대한 .cells(i,7).cells(i,11)에서 변경.

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