如何从excel复制范围到outlook忽略filter适用的第一列？

您好我有一个代码，将过滤A列中的唯一值，并复制整个范围从A1：H，但我想忽略第一列，并希望范围从B1：H复制。

例如：如果有一张带有学生分数的桌子，我想单独向每个学生张贴个人分数表。 这个macros是和第一列的学生名字一起发送的，但是我只需要标记表格，不需要学生的名字。

这是我的代码

Sub Send_Row_Or_Rows_1() Dim OutApp As Object Dim OutMail As Object Dim rng As Range Dim Ash As Worksheet Dim Cws As Worksheet Dim Rcount As Long Dim Rnum As Long Dim FilterRange As Range Dim FieldNum As Integer Dim mailAddress As String Dim StrBody As String On Error GoTo cleanup Set OutApp = CreateObject("Outlook.Application") With Application .EnableEvents = False .ScreenUpdating = False End With Set Ash = ActiveSheet 'Set filter range and filter column (Column with names) Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count) FieldNum = 1 'Filter column = A because the filter range start in A 'Add a worksheet for the unique list and copy the unique list in A1 Set Cws = Worksheets.Add FilterRange.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=Cws.Range("A1"), _ CriteriaRange:="", Unique:=True 'Count of the unique values + the header cell Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1)) 'If there are unique values start the loop If Rcount >= 2 Then For Rnum = 2 To Rcount 'Filter the FilterRange on the FieldNum column FilterRange.AutoFilter Field:=FieldNum, _ Criteria1:=Cws.Cells(Rnum, 1).Value 'Look for the mail address in the MailInfo worksheet mailAddress = "" On Error Resume Next mailAddress = Application.WorksheetFunction. _ VLookup(Cws.Cells(Rnum, 1).Value, _ Worksheets("Mailinfo").Range("A1:B" & _ Worksheets("Mailinfo").Rows.Count), 2, False) On Error GoTo 0 If mailAddress <> "" Then With Ash.AutoFilter.Range On Error Resume Next Set rng = .SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .to = mailAddress .Subject = "Test mail" .HTMLBody = StrBody & RangetoHTML(rng) .Display 'Or use Send StrBody = Sheets("Body").Range("A1").Value & "<br>" & _ Sheets("Body").Range("A2").Value & "<br>" & _ Sheets("Body").Range("A3").Value & "<br><br><br>" End With On Error GoTo 0 Set OutMail = Nothing End If 'Close AutoFilter Ash.AutoFilterMode = False Next Rnum End If cleanup: Set OutApp = Nothing Application.DisplayAlerts = False Cws.Delete Application.DisplayAlerts = True With Application .EnableEvents = True .ScreenUpdating = True End With End Sub 

Answer 1

如果你想坚持使用你的解决scheme而不是使用Word的邮件工具 ，

只要改变这一行：

 Set rng = .SpecialCells(xlCellTypeVisible) 

至

 Set rng = Application.Intersect(.SpecialCells(xlCellTypeVisible),Ash.Range("B:H")) 

Answer 2

通过使用偏移量，您可以select没有标题或标题的特定过滤列

请看下面的代码：

 Set rng = .AutoFilter.Range.Offset(1, ColumnNumber).Resize(.AutoFilter.Range.Rows.Count - 1, ColumnCount).SpecialCells(xlCellTypeVisible) 

ColumnNumber – 启动要复制的列ColumnCount – 要复制的列数

尝试下面的一个：

set rng = Ash.Autofilter.Range.Offset（1）.Resize（Ash.AutoFilter.Range.Rows.Count – 1,7）.SpecialCells（xlCellTypeVisible）