VBA macro which considers filtered data-CodePudding

I have a macro that sends emails from data on a sheet. The problem is, I need my macro to work on filtered data, not entire sheet.

I found this solution for one row here:

 Sub SpecialLoop()
    Dim cl As Range, rng As Range
    
    Set rng = Range("A2:A11")
    
    For Each cl In rng.SpecialCells(xlCellTypeVisible)
        Debug.Print cl
    Next cl

End Sub

But I don't know how to apply it to my code, where many rows affected. Here is the part of my code, where the SpecialCells should be applied, I suppose:

Set objOL = CreateObject("Outlook.Application")
objOL.Session.Logon

Set objxls = CreateObject("Excel.Application")
objxls.Workbooks.Open "Email_addresses.xlsx"
objxls.Application.Visible = True

Set RegionwithData = objxls.Worksheets("Sheet1").[a2].CurrentRegion
LastR = RegionwithData(Rows.Count, 1).End(xlUp).Row
                                                               
                                                               
For lr = 2 To LastR
  
    Set objmsg = objOL.CreateItemFromTemplate("Template.oft")
 
    With objmsg
        .Display
        .To = objxls.Worksheets("Sheet1").Cells(lr, 3).Value
        .BCC = objxls.Worksheets("Sheet1").Cells(lr, 4).Value
        .Subject = objxls.Worksheets("Sheet1").Cells(lr, 6).Value
        .Send
    End With

Application.Wait (Now   TimeValue("0:00:01"))

Next lr

I tried changing the loop and objxls, but nothing worked. Please help me to make my code work properly :c

CodePudding user response：

If a filtered range has non-contiguous regions you have to loop through the rows in each area or alternatively the cells in a single column.

Option Explicit

Sub macro1()

    Dim objOL As Object, objxls As Object, objmsg As Object
    Dim wb As Workbook
    Set objOL = CreateObject("Outlook.Application")
    objOL.Session.Logon

    Set objxls = CreateObject("Excel.Application")
    objxls.Application.Visible = True
    Set wb = objxls.Workbooks.Open("Email_addresses.xlsx")
    
    Dim RegionwithData As Range, cell As Range, lr As Long
    With wb.Sheets("Sheet1")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        On Error Resume Next
        Set RegionwithData = .Range("C2:C" & lr).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With

    If RegionwithData Is Nothing Then
        MsgBox "No data", vbExclamation
    Else
        With RegionwithData
            For Each cell In RegionwithData.Cells
                Set objmsg = objOL.CreateItemFromTemplate("Template.oft")
                With objmsg
                    .To = cell.Value
                    .BCC = cell.Offset(0, 1).Value
                    .Subject = cell.Offset(0, 3).Value
                    .Display
                    '.Send
                End With
                Application.Wait (Now   TimeValue("0:00:01"))
            Next
        End With
    End If
    wb.Close False
End Sub