求助用vba统计手机号出现的次数

waw751115

请教怎样用vba统计附件表格中手机号出现的次数？

cnmlgb9998

PQ ！！！！！！！！！！！！！！！！！！！！！！！！

fzxba

1. Sub test1()
   
2.   Dim Conn As Object, SQL As String, strConn As String
   
3.   
   
4.   Set Conn = CreateObject("ADODB.Connection")
   
5.   If Application.Version < 12 Then
   
6.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
   
7.   Else
   
8.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
   
9.   End If
   
10.   Conn.Open strConn & ThisWorkbook.FullName
    
11.   
    
12.   SQL = "SELECT 手机号,COUNT(手机号) AS 数量 FROM [Sheet1$A:A] WHERE LEN(手机号) GROUP BY 手机号"
    
13.   SQL = "SELECT 数量 AS 次数,COUNT(手机号) AS 数量 FROM (" & SQL & ") GROUP BY 数量"
    
14.   
    
15.   With Range("G1")
    
16.     .CurrentRegion.Clear
    
17.     .Resize(, 2) = Split("次数 数量")
    
18.     .Offset(1).CopyFromRecordset Conn.Execute(SQL)
    
19.   End With
    
20.   
    
21.   Conn.Close
    
22.   Set Conn = Nothing
    
23. End Sub

复制代码

fzxba

123.zip (190.8 KB, 下载次数: 14)

2024-3-6 12:25 上传

点击文件名下载附件

Meteor-渣渣

这跟手机号有什么关系？

fzxba

Sub test2() '还来一个灌一灌
  Dim dict As Object
  Dim ar, i As Long, j As Long, k As Long, p As Long, s As String
  
  k = 1
  Set dict = CreateObject("Scripting.Dictionary")
  
  ar = Range("B1", Cells(Rows.Count, "A").End(xlUp))
  ar(k, 1) = "次数": ar(k, 2) = "数量"
  
  For i = 2 To UBound(ar)
    s = Trim(ar(i, 1))
    If Len(s) Then
      If Not dict.Exists(s) Then
        k = k + 1
        ar(k, 1) = 1
        dict.Add s, k
      Else
        p = dict(s)
        ar(p, 1) = ar(p, 1) + 1
      End If
    End If
  Next
  
  Set dict = Nothing
  QuickSort ar, 2, k, UBound(ar, 2) - 1
  
  s = vbNullString
  j = 1
  For i = 2 To k
    If Trim(ar(i, 1)) <> s Then
      s = Trim(ar(i, 1))
      j = j + 1
      ar(j, 1) = s
      ar(j, 2) = 1
    Else
      ar(j, 2) = ar(j, 2) + 1
    End If
  Next
  
  With Range("J1")
    .CurrentRegion.Clear
    .Resize(j, UBound(ar, 2)) = ar
  End With
  
End Sub

Function QuickSort(ar, L1 As Long, U1 As Long, pos As Long)
  Dim up As Long, dn As Long, pivot As Long, swap As Long
  up = L1
  dn = U1
  pivot = ar((L1 + U1) \ 2, pos)
  While up <= dn
    Do
      If ar(up, pos) < pivot Then up = up + 1 Else Exit Do
    Loop While up < U1
    Do
      If ar(dn, pos) > pivot Then dn = dn - 1 Else Exit Do
    Loop While dn > L1
    If up < dn Then
      swap = ar(up, 1): ar(up, 1) = ar(dn, 1): ar(dn, 1) = swap
      up = up + 1: dn = dn - 1
    Else
      If up = dn Then up = up + 1: dn = dn - 1
    End If
  Wend
  If up < U1 Then QuickSort ar, up, U1, pos
  If dn > L1 Then QuickSort ar, L1, dn, pos
End Function

waw751115

fzxba 发表于 2024-3-6 12:25

谢谢，我怎么想不到用两次查询呢？谢谢

fzxba

waw751115 发表于 2024-3-6 14:59
谢谢，我怎么想不到用两次查询呢？谢谢

数组适当结合字典更快，已发，在审核……

grf1973

。。。。。。。。。。。

grf1973

wps版本的。