派出所的一個朋友在調查一起案件的時候，遇到了一個如題的問題，請我幫忙。由於要保密他不能提供原始資料，只是給我談了一下要求。目前他們透過一個嫌疑犯的通話記錄，從通話記錄中又列入了n個新嫌疑犯，而且也得到每個嫌疑犯的通話記錄。現在就要將這些通話記錄進行統計，即同一個電話號碼，每個嫌疑犯打了多少次，有多少個嫌疑犯同時打過同一個號碼。
根據上述總結，excel表如下：
圖一：原始資料表電腦教程
圖二：統計結果表
上圖說明：
圖一：使用者一、使用者二、使用者三、使用者四正面的數字為模擬的電話號碼;方向是指主叫還是被叫，沒有什麼意義。
圖二：使用者正面的數字是該電話所使用的次數，如果一個電話只被某一使用者打過，這樣就不統計，換句話說就是統計結果表中的電話號碼至少被兩個以上的使用者打過。
解決的思路：
⒈ 此統計無法使用函式、資料透視表等普通的方法來解決。我採用了VBA程式設計來實現的統計。
⒉ 首先將所有使用者的電話(不重複，重複的只取一次)，提取出來存放到統計結果表中。這樣結果表中的電話是唯一的。
⒊ 透過結果表的電話號碼為基礎，統計每個使用者使用該號碼的次數並將統計的結果存放到結果表該使用者下。
⒋ 刪除同一個電話號碼被兩個以下使用者使用的行。
解決的方法：
⒈ 因為使用者的數量是未知的，但從第2列開始是已經的，這樣我們就可以透過迴圈來進行統計。迴圈的條件透過第1行從第2列開始，單元格不空。
⒉ 每個使用者的電話號碼迴圈與⒈類似
具體的程式原始碼如下：
Private Sub CommandButton1_Click()
Sheets(2).Rows(2 & ":" & 65536) = ""
Sheets(2).Columns("B:IV") = ""
Dim Ls, i, j, Isa, k, yhs
Isa = False
i = 2
If Sheets(1).Cells(1, 2) = "" Then
MsgBox "沒有使用者，無法統計!", vbOKOnly + vbCritical, "錯誤提示"
Exit Sub
Else
Do While True
If Sheets(1).Cells(1, i) <> "" Then
Sheets(2).Cells(1, i) = Sheets(1).Cells(1, i)
i = i + 1
Else
Exit Do
End If
Loop
yhs = i - 1
End If
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
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
'===========================================
' 刪除非同一電話多個使用者使用的行
'===========================================
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 '刪除i行
Else
i = i + 1
End If
Loop
'===========================================
MsgBox "統計完畢!", vbOKOnly + vbInformation, "系統提示"
Sheets(2).Select
End Sub