複数のシートと特定の範囲を1枚のシートにメールする

Question

Sheet 3からSheet 1とRange（ "A7：P20"）のすべてを電子メールで送信するマクロを作成しようとしています。シート全体を送信するが、私は、私は唯一のあなたが設定Destwb後にこのコードを追加することができます。1.

Sub Mail_Sheets_Array() 
'Working in Excel 2000-2016 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
    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 
    Dim sh As Worksheet 
    Dim TheActiveWindow As Window 
    Dim TempWindow As Window 

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

    Set Sourcewb = ActiveWorkbook 

    'Copy the sheets to a new workbook 
    'We add a temporary Window to avoid the Copy problem 
    'if there is a List or Table in one of the sheets and 
    'if the sheets are grouped 
    With Sourcewb 
     Set TheActiveWindow = ActiveWindow 
     Set TempWindow = .NewWindow 
     .Sheets(Array("Sheet1", "Sheet3")).Copy 
    End With 

    'Close temporary Window 
    TempWindow.Close 

    Set Destwb = ActiveWorkbook 

    'Determine the Excel version and file extension/format 
    With Destwb 
     If Val(Application.Version) < 12 Then 
      'You use Excel 97-2003 
      FileExtStr = ".xls": FileFormatNum = -4143 
     Else 
      'You use Excel 2007-2016 
      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 

    ' 'Change all cells in the worksheets to values if you want 
    ' For Each sh In Destwb.Worksheets 
    '  sh.Select 
    '  With sh.UsedRange 
    '   .Cells.Copy 
    '   .Cells.PasteSpecial xlPasteValues 
    '   .Cells(1).Select 
    '  End With 
    '  Application.CutCopyMode = False 
    '  Destwb.Worksheets(1).Select 
    ' Next sh 

    'Save the new workbook/Mail it/Delete it 
    TempFilePath = Environ$("temp") & "\" 
    TempFileName = "Part of " & 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 
     With OutMail 
      .to = "ron@debruin.nl" 
      .CC = "" 
      .BCC = "" 
      .Subject = "This is the Subject line" 
      .Body = "Hi there" 
      .Attachments.Add Destwb.FullName 
      'You can add other files also like this 
      '.Attachments.Add ("C:\test.txt") 
      .Send 'or use .Display 
     End With 
     On Error GoTo 0 
     .Close savechanges:=False 
    End With 

    'Delete the file you have send 
    Kill TempFilePath & TempFileName & FileExtStr 

    Set OutMail = Nothing 
    Set OutApp = Nothing 

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

Answer 1

シートのすべてに加えて、個別のシートにシート3から上記の範囲を送るように調整するかどうかはわかりませんよ=アクティブワークブック。

Dim LastRowDest as Long 
Dim LastColDest as Long 

Destwb.sheets("sheet3").Select 
LastRowDest = Destwb.sheets("sheet3").cells(rows.count,1).end(xlup).row 
LastColDest = Destwb.sheets("sheet3").cells(1,columns.count).end(xltoleft).column 

sheets("sheet3").Rows("21:" & LastRowDest + 1).Delete 
sheets("sheet3").Rows("1:6").Delete 
sheets("sheet3").columns("17:& LastColDest + 1).Delete 

このヘルプが必要です。