VBA:选择第一个过滤的单元格然后向下移动到下一个单元格

Question

我想做的事情对我来说似乎很简单,但我找不到办法.我有一个excel电子表格,其中包含很多联系方式,例如:

    A                 B            C            D                    E
1   Select who you would to like to email:      * Drop down list *
2   Name:            Company:      Role:        Email Address1:      Email Address2:
3   Michael Jackson  Jackson 5     Singer       MJ@J5.com            Michael@J5.com
4   Brian May        Queen         Guitarist    BM@Queen.com         Brian@Queen.com
5   Kurt Cobain      Nirvana       Singer       KC@Nirvana.com       Kurt@Nirvana.com
6   Freddie Mercury  Queen         Singer       FM@Queen.co.uk       Freddie@Queen.com
7   Pat Smear        Nirvana       Guitarist    PS@Foo.com           Pat@Foo.com

用户使用下拉列表D1(例如电子邮件1)选择他们想要发送电子邮件的电子邮件地址,然后运行一个宏来获取该列中的电子邮件地址.这一点很好,我有它的工作.问题是,当用户应用过滤器时,比如所有吉他手,它将选择第一个过滤的行(C4)然后转到下一行而不是下一个过滤的行,所以它会去C5.

这是我目前使用的代码的改编:

Sub SendEmail()

Dim objOutlook As Object
Dim objMail As Object
Dim RowsCount As Integer
Dim Index As Integer
Dim Recipients As String
Dim Category As String
Dim CellReference As Integer

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

RowsCount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1

Category = Range("D1")
Dim RowLimit As String
If Category = "Email Address1" Then
    CellReference = 4
ElseIf Category = "Email Address2" Then
    CellReference = 5
End If

Index = 0
While Index < RowsCount
    Set EmailAdrs = ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, CellReference).Offset(0 + Index, 0)
    Recipients = Recipients & EmailAdrs.Value & ";"
    Index = Index + 1
Wend

 With objMail
    .To = Recipients
    .Subject = "This is the subject"
    .Display
End With

Set objOutlook = Nothing
Set objMail = Nothing

End Sub

但是这只会选择第一个过滤的细胞,然后选择低于该细胞的细胞.

我尝试了很多不同的想法,例如循环隐藏的行:

While Index < RowsCount
   Do While Rows(ActiveCell.Row).Hidden = True
       'ActiveCell.Offset(1).Select
       Set EmailAdrs = ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, CellReference).Offset(0 + Index, 0)
        Recipients = Recipients & EmailAdrs.Value & ";"
        Index = Index + 1
        ActiveCell = ActiveCell.Offset(0 + Index, 0).Select
    Loop
Wend

我试过只查看可见的细胞.

我从另一个StackOverflow问题尝试了其他人的想法(VBA转到下一个过滤的单元格):

If ActiveSheet.FilterMode = True Then
    With ActiveSheet.AutoFilter.Range
        For Each a In .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).Areas
            Recipients = Recipients & a(1, CellReference) & ";"
        Next
    End With
    MsgBox Replace(Recipients, ";;", vbNullString)
End If

和:

Dim Rng As Range
If Category = Range("S2") Then
    CellReference = 10
    'Set your range
    Set Rng = Range("A1:B2")
ElseIf Category = Range("S3") Then
    CellReference = 14
    'Set your range
    Set Rng = Range("C1:D2")
ElseIf Category = Range("S4") Then
    CellReference = 18
    'Set your range
    Set Rng = Range("F1:G2")
ElseIf Category = Range("S5") Then
    CellReference = 16
    'Set your range
    Set Rng = Range("H1:J2")
End If

For Each mCell In ThisWorkbook.Sheets("YourSheetName").Range(Rng).SpecialCells(xlCellTypeVisible)
    'Get cell address
    mAddr = mCell.Address
    'Get the address of the cell on the column you need
    NewCellAddr = mCell.Offset(0, ColumnsOffset).Address
    'Do everything you need
Next mCell

以及来自其他网页的各种其他想法和事情,但它们似乎不起作用.

有人可以帮助我,请记住我是VBA的新手,所以没有太多的知识.

Answer 1

试试这段代码:

Sub SendEmail()
    Dim objOutlook As Object
    Dim objMail As Object
    'Dim RowsCount As Integer
    'Dim Index As Integer
    Dim Recipients As String
    Dim Category As String
    Dim CellReference As Integer
    Dim RowLimit As String
    'New variables.
    Dim firstRow As Long
    Dim lastRow As Long
    Dim cell As Excel.Range
    Dim row As Long



    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)


    Category = Range("D1")
    If Category = "Email Address1" Then
        CellReference = 4
    ElseIf Category = "Email Address2" Then
        CellReference = 5
    End If



    With ActiveSheet

        'Find the first and last index of the visible range.
        firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).row
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).row


        'Iterate through all the rows between [firstRow] and [lastRow] established before.
        'Some of those rows are hidden, but we will check it inside this loop.
        For row = firstRow To lastRow

            Set cell = .Cells(row, CellReference)

            'We are checking here if this row is hidden or visible.
            'Note that we cannot check the value of property Hidden of a single cell,
            'since it will generate Run-time error '1004' because a single cell cannot be
            'hidden/visible - only a whole row/column can be hidden/visible.
            'That is why we need to refer to its .EntireRow property first and after that we
            'can check its .Hidden property.
            If Not cell.EntireRow.Hidden Then

                'If the row where [cell] is placed is not hidden, we append the value of [cell]
                'to variable Recipients.
                Recipients = Recipients & cell.Value & ";"
            End If

        Next row

    End With


    With objMail
        .To = Recipients
        .Subject = "This is the subject"
        .Display
    End With

    Set objOutlook = Nothing
    Set objMail = Nothing

End Sub