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