统计个数且在每个单元格右边标出

wowo000

论坛里的每位老师：早上好！劳烦帮俺实现附件里函数公式的结果（因为数据量有好几十万，公式太卡），谢谢！

wanghui834

1. Sub 计个数test()
   
2.     Dim r&, i&, s1 As Double, s2 As Double
   
3.     Dim Arr, Brr, Crr, Drr, ge
   
4.     With Worksheets("Sheet2")
   
5.         r = .Cells(.Rows.count, 1).End(xlUp).Row
   
6.         Arr = .Range("A2:A" & r)
   
7.         ge = 0
   
8.         ReDim Crr(1 To r, 1 To 1)
   
9.         For i = 1 To UBound(Arr)
   
10.             Crr(i, 1) = Application.WorksheetFunction.CountIf(.Range("A2:A" & r), Arr(i, 1))
    
11.         Next
    
12.         .Range("c2:c" & r).ClearContents
    
13.         .Range("c2").Resize(r, 1) = Crr
    
14.     End With
    
15. End Sub
    

复制代码

shiruiqiang

一招秒杀

区区1个 Sum(1) Over (Partition By 目的站)  函数搞定，简单到不要不要的

taller

1. Sub SqlDemo()
   
2.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
3.     Set conn = CreateObject("ADODB.Connection")
   
4.     Set rst = CreateObject("ADODB.Recordset")
   
5.     PathStr = ThisWorkbook.FullName                                     '路径
   
6.     Select Case Application.Version * 1
   
7.         Case Is <= 11
   
8.             conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
   
9.         Case Is >= 12
   
10.             conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
11.     End Select
    
12.     strSQL = "select b.*, a.cnt as 个数 from [Sheet2$A:A] as b left join ( Select 目的站, Count(1) As cnt From [Sheet2$A:A] GROUP BY 目的站 ) as a On a.目的站=b.目的站"
    
13.     rst.Open strSQL, conn, 1, 1
    
14.     Set sht = ActiveSheet
    
15.     With sht
    
16.         For i = 0 To rst.Fields.Count - 1
    
17.             .Cells(1, i + 1) = rst.Fields(i).Name
    
18.         Next i
    
19.         .Range("a2").CopyFromRecordset rst
    
20.     End With
    
21.     rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
22. End Sub
    

复制代码

z865593849

字典实现countif

ykcbf1100

改一下，用字典吧。

ykcbf1100

原代码基础上改一下吧。

1. Sub 计个数()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Worksheets("Sheet2")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         Arr = .Range("A1:B" & r)
   
6.         For i = 2 To UBound(Arr)
   
7.             s = Arr(i, 1)
   
8.             d(s) = d(s) + 1
   
9.         Next
   
10.         For i = 2 To UBound(Arr)
    
11.             Arr(i, 2) = d(Arr(i, 1))
    
12.         Next
    
13.         .Range("A1:B" & r) = Arr
    
14.     End With
    
15. End Sub
    

复制代码

Qs18

1. Sub 计个数()
   
2.     Dim r&, i&, s1 As Double, s2 As Double
   
3.     Dim Arr, Brr, Crr, Drr, ge, dic
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     With Worksheets("Sheet2")
   
6.         r = .Cells(.Rows.count, 1).End(xlUp).Row
   
7.         Arr = .Range("A1:A" & r)
   
8.         For i = 2 To UBound(Arr)
   
9.             If Not dic.exists(Arr(i, 1)) Then
   
10.                 dic(Arr(i, 1)) = 1
    
11.             Else
    
12.                 dic(Arr(i, 1)) = dic(Arr(i, 1)) + 1
    
13.             End If
    
14.         Next
    
15.         For i = 2 To UBound(Arr)
    
16.             Arr(i, 1) = dic(Arr(i, 1))
    
17.         Next
    
18.         .Range("B2:B" & r).ClearContents
    
19.         .Range("B1").Resize(r, 1) = Arr
    
20.     End With
    
21. Set dic = Nothing
    
22. End Sub
    

复制代码

Qs18

试试..........