求助代码统计

1吧吧 · 发表于 2024-8-10 17:36

求助代码统计

longwin · 发表于 2024-8-10 17:53

1吧吧 · 发表于 2024-8-10 18:24

还要排序的

gwjkkkkk · 发表于 2024-8-10 18:33

..................................

1吧吧 · 发表于 2024-8-10 19:13

本帖最后由 1吧吧于 2024-8-13 17:08 编辑

测试结果出错

1吧吧 · 发表于 2024-8-10 19:15

醉眼看尘世 · 发表于 2024-8-10 19:47

把上楼代码改改就行了

醉眼看尘世 · 发表于 2024-8-10 19:48

Sub test()
Dim rG As Range
Set D = CreateObject("scripting.dictionary")
Arr = Sheets("Sheet1").Range("B1:E" & Sheets("Sheet1").UsedRange.Rows.Count)
For i = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
If Arr(i, j) <> "" Then
D(Arr(i, j)) = D(Arr(i, j)) + 1
End If
Next
Next
'Sheets("Sheet2").[B1].Resize(D.Count, 2) = WorksheetFunction.Transpose(Array(D.keys, D.items))
ReDim Brr(1 To D.Count, 1 To 2)
x = 0
For Each k In D.keys
x = x + 1
Brr(x, 1) = k: Brr(x, 2) = D(k)
Next k
With Sheet2
Set rG = .[B1].Resize(D.Count, 2)
rG = Brr
rG.Sort rG.Column(2), xlDescending, , , , , , xlNo
End With
End Sub

复制代码

1吧吧 · 发表于 2024-8-10 21:35

本帖最后由 1吧吧于 2024-8-11 10:23 编辑

测试结果出错
看5楼附件

3190496160 · 发表于 2024-8-11 09:10

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = Sheets("Sheet1").Range("B1:E" & Sheets("Sheet1").UsedRange.Rows.Count)
Dim br()
ReDim br(1 To 900000, 1 To 2)
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
      If arr(i, j) <> "" Then
         t = d(arr(i, j))
         If t = "" Then
            k = k + 1
            d(arr(i, j)) = k
            t = k
            br(k, 1) = arr(i, j)
         End If
         br(t, 2) = br(t, 2) + 1
      End If
Next j
Next i
With Sheets("Sheet2")
.Columns("b:c") = Empty
.[b1].Resize(k, 2) = br
End With
MsgBox "ok!"
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 求助代码统计

评分

[求助] 求助代码 统计

评分

[求助] 求助代码统计