Mail catre adrese vizibile dupa filtru

[tyro_excel_vba]

Buna,

Am o lista de contacte pe tari, fiecare tara putand avea intre 1 si 5 contacte. Pe coloana C am adresa de mail a contactului, iar pe coloana M am tara.
Vreau ca in .to sa se populeze automat adresele de mail din coloana C, ce raman vizibile dupa ce pun filtru pe tara.

Am gasit un cod pe net, functioneaza, doar ca eu imi doresc sa nu stau sa selectez eu range-ul si sa pot programa asta din VBA. Sa se uite pe coloana C, sa ia toate adresele de mail vizibile (sa sara peste capatul de tabel) si sa le puna in To cu ; intre ele.


codul de pe net:

Cod: Selectaţi tot

Sub sendmultiple()

    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the addresses list:", "Select the range", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    Set xMItem = xOTApp.CreateItem(0)
    With xMItem
        .To = xEmailAddr
        .Display
    End With
End Sub

[Dr.Windows]

Salut!

Daca nu vrei sa "alegi" doar trebuie sa definesti tu zona de parcurs. Adica in loc de

Cod: Selectaţi tot

Set xRg = Application.InputBox("Please select the addresses list:", "Select the range", xTxt, , , , , 8)

foloseste

Cod: Selectaţi tot

Set xRg = Range("C2:C1000")

Acum daca nu vrei sa pui o adresa fixa vezi aici cum poti sa detectezi ultimul rand: 5 Different Ways to Find The Last Row or Last Column Using VBA.

In plus codul mai avea o problema - functiona numai daca celulele filtrate erau adiacente, sau aveai grija sa selectezi doar ce se vede. Ca sa utilizeze doar celulele vizibile ar mai trebui modificata linia:

Cod: Selectaţi tot

If xCell.Value Like "*@*" Then

cu asta

Cod: Selectaţi tot

If xCell.Value Like "*@*" And xCell.EntireRow.Hidden = False Then

Astfel, codul final ar fi asta:

Cod: Selectaţi tot

Sub sendmultiple()

    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Range("C2:C1000")
    If xRg Is Nothing Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")
    For Each xCell In xRg
        If xCell.Value Like "*@*" And xCell.EntireRow.Hidden = False Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    Set xMItem = xOTApp.CreateItem(0)
    With xMItem
        .To = xEmailAddr
        .Display
    End With
End Sub

[tyro_excel_vba]

Functioneaza! Multumesc!!!