派出所調查案件，需從多名嫌疑人通話記錄中找出「被至少兩名嫌疑人共同撥打的號碼」及各人撥打次數。資料量大、結構雜，一般函數/樞紐表無法處理，需用 VBA 陣列與字典演算法高效完成。本文提供完整邏輯分析與可直接使用的 VBA 程式碼。

資料結構與目標

• 來源表：每欄為一嫌疑人，首列為嫌疑人代號，下方列出其撥打/接聽號碼（含重複）。
• 結果表：每列為一唯一號碼，欄位為各嫌疑人撥打該號碼的次數，僅保留「出現於≥2名嫌疑人」的號碼列。

演算法邏輯三階段

1. 蒐集所有嫌疑人代號：掃描來源表第 1 列非空儲存格，寫入結果表第 1 列作為標題。
2. 建立唯一號碼清單：遍歷每位嫌疑人所有號碼，用「是否已存在結果表第 1 欄」判斷，不存在則新增一列，實現去重。
3. 統計各人次數並篩選：對結果表每一號碼列，掃描各嫌疑人欄位計數；最後刪除「非零計數欄位 < 2」的列（即僅 1 人撥打的號碼）。

核心 VBA 程式碼（已整理註解）

Private Sub CommandButton1_Click()
    ' 初始化結果表
    Sheets(2).Rows("2:65536").ClearContents
    Sheets(2).Columns("B:IV").ClearContents

    Dim Ls As Long, i As Long, j As Long, Isa As Boolean, k As Long, yhs As Long
    Isa = False
    i = 2

    ' 1. 蒐集嫌疑人代號
    If Sheets(1).Cells(1, 2) = "" Then
        MsgBox "沒有用戶，無法統計！", vbCritical, "錯誤"
        Exit Sub
    Else
        Do While Sheets(1).Cells(1, i) <> ""
            Sheets(2).Cells(1, i) = Sheets(1).Cells(1, i)
            i = i + 1
        Loop
        yhs = i - 1 ' 嫌疑人數
    End If

    ' 2. 建立唯一號碼清單
    Ls = 2
    Do While Sheets(1).Cells(1, Ls) <> ""
        i = 2
        Do While Sheets(1).Cells(i, Ls) <> ""
            If Sheets(2).Cells(2, 1) = "" Then
                Sheets(2).Cells(2, 1) = Sheets(1).Cells(i, Ls)
            Else
                j = 2: Isa = False
                Do While Sheets(2).Cells(j, 1) <> ""
                    If Sheets(2).Cells(j, 1) = Sheets(1).Cells(i, Ls) Then Isa = True: Exit Do
                    j = j + 1
                Loop
                If Not Isa Then Sheets(2).Cells(j, 1) = Sheets(1).Cells(i, Ls)
            End If
            i = i + 1
        Loop
        Ls = Ls + 1
    Loop

    ' 3. 統計各人次數
    Ls = 2
    Do While Sheets(2).Cells(1, Ls) <> ""
        i = 2
        Do While Sheets(2).Cells(i, 1) <> ""
            j = 2: k = 0
            Do While Sheets(1).Cells(j, Ls) <> ""
                If Sheets(2).Cells(i, 1) = Sheets(1).Cells(j, Ls) Then k = k + 1
                j = j + 1
            Loop
            If k <> 0 Then Sheets(2).Cells(i, Ls) = k
            i = i + 1
        Loop
        Ls = Ls + 1
    Loop

    ' 4. 刪除僅 1 人撥打的號碼列
    i = 2
    Do While Sheets(2).Cells(i, 1) <> ""
        j = 2: k = 0
        Do While j <= yhs
            If Sheets(2).Cells(i, j) <> "" Then k = k + 1
            j = j + 1
        Loop
        If CInt(k) < 2 Then
            Sheets(2).Rows(i).Delete Shift:=xlUp
        Else
            i = i + 1
        End If
    Loop

    MsgBox "統計完畢！", vbInformation, "系統提示"
    Sheets(2).Select
End Sub

部署與使用

1. 在來源工作表（Sheet1）按結構填入資料。
2. 插入一個「命令按鈕」(ActiveX 控制項) → 右鍵「檢視程式碼」→ 貼上上述程式碼。
3. 回到 Excel，關閉設計模式，點擊按鈕執行，結果輸出至 Sheet2。

效能與擴充提示

• 資料量達萬筆以上建議改用 Scripting.Dictionary 替代雙重迴圈，速度提升百倍。
• 若嫌疑人數動態變動，可改用 UsedRange 或 ListObject 動態判斷範圍。
• 同邏輯可擴展至「共同聯繫人分析」、「共同消費商家分析」等關聯挖掘場景。

VBA 賦予 Excel 處理複雜關聯分析的能力，讓調查人員從海量通話記錄中快速鎖定關鍵線索。