邮寄多张表和一张表内的特定范围

我正在尝试编写一个macros，它将从表3中的所有Sheet 1和Range（“A7：P20”）中发送电子邮件。我复制下面的代码，用于发送整个工作表，但我不确定如何调整除了所有的Sheet 1之外，我只把一张表格3中的上述范围发送到一张不同的纸上。

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 = "[e-mail]" .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

设置Destwb = ActiveWorkbook后，您可以添加此代码。

 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 

希望这个帮助。