|
本帖最后由 melville 于 2019-6-13 16:39 编辑
代码如下- Sub tt()
- Dim d1 As Object
- Dim arr, brr
- Dim i As Long
- Dim j, k As Integer
- Dim s As String
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d1 = CreateObject("Scripting.Dictionary")
-
- k = 0
- arr = Sheet1.Range("A1").CurrentRegion
- ReDim brr(1 To UBound(arr, 1), 1 To 3)
-
- For i = 2 To UBound(arr)
- s = arr(i, 2) & "/" & arr(i, 3)
- If s <> "" Then
- If d1.Exists(s) Then
- brr(d1(s), 3) = brr(d1(s), 3) + 1
- Else
- k = k + 1: d1(s) = k
- brr(k, 1) = arr(i, 2): brr(k, 2) = arr(i, 3): brr(k, 3) = 1
- End If
- End If
- Next
-
- j = Sheet1.[E65536].End(xlUp).Row
- If j > 2 Then
- Sheet1.Range(sheet1.Cells(2, 5),sheet1 .Cells(j, 7)).ClearContents '清除原有内容
- End If
-
- sheet1.Range("E2").Resize(k, 3) = brr
-
- Set d1 = Nothing
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
复制代码
|
评分
-
2
查看全部评分
-
|