2023年7月12日 星期三

VBA_列出mail地址

 A工作表的B欄是收件人的mail位址,不同收件人以,分隔,C欄顯示mail位置,D欄顯示mail出現次數,E欄顯示抓取@之後的內容。


VBA代碼如下:



Sub CountRecipients()

    Dim ws As Worksheet

    Dim lastRow As Long

    Dim recipients As String

    Dim recipientList() As String

    Dim recipient As Variant

    Dim dict As Object

    

    Set ws = ThisWorkbook.Sheets("A") ' 將 "A" 替換為你的工作表名稱

    

    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    

    Set dict = CreateObject("Scripting.Dictionary")

    

    ' 遍歷B欄中的每個儲存格,將收件人位址以逗號分隔的方式拆分並統計數量

    For i = 1 To lastRow

        recipients = ws.Cells(i, "B").Value

        recipientList = Split(recipients, ",")

        For Each recipient In recipientList

            recipient = Trim(recipient)

            If recipient <> "" Then

                If Not dict.Exists(recipient) Then

                    dict(recipient) = 1

                Else

                    dict(recipient) = dict(recipient) + 1

                End If

            End If

        Next recipient

    Next i

    

    ' 將統計結果輸出到C、D和E欄

    ws.Range("C1").Value = "Mail Address"

    ws.Range("D1").Value = "Count"

    ws.Range("E1").Value = "Domain"

    i = 2

    For Each recipient In dict.Keys

        ws.Cells(i, "C").Value = recipient

        ws.Cells(i, "D").Value = dict(recipient)

        ws.Cells(i, "E").Value = Mid(recipient, InStr(recipient, "@") + 1)

        i = i + 1

    Next recipient

    

    Set dict = Nothing

End Sub


沒有留言:

張貼留言

清洗儲熱桶熱水器

1/4,我自行拆下儲熱桶的電熱棒,清理內部並排除其中的泥沙。上一次清理是在2017/12/31(事隔7年),當時請維修人員檢查熱水器不熱的原因,順便清理了儲熱桶內的泥沙和結晶。當時我觀察工人拆裝的方式,發現操作相當簡單,因此這次決定自己動手處理。拆下後發現泥沙比想像中少,讓我不禁...