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