Excel统计某电话号码有多少人打过

派出所的一个朋友在调查一起案件的时候，遇到了一个如题的问题，请我帮忙。由于要保密他不能提供原始数据，只是给我谈了一下要求。目前他们通过一个嫌疑犯的通话记录，从通话记录中又列入了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