求助代码求助代码

1吧吧

求助代码求助代码

longwin

longwin

Sub test()
    arr = Sheets("Sheet2").Range("B1:B9")
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(Mid(arr(i, 1), 1, 1)) = d(Mid(arr(i, 1), 1, 1)) + 1
    Next
    Sheets("Sheet3").Range("B1:C" & d.Count) = WorksheetFunction.Transpose(Array(d.keys, d.items))
    Set d = Nothing
End Sub

jaxxcyh

1. Sub test()
   
2. 
   
3.     Dim d As Object
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.    
   
6.     Dim arr
   
7.     arr = Sheets("sheet2").Range("b1").CurrentRegion
   
8.    
   
9.     Dim s As String
   
10.    
    
11.     For i = 1 To UBound(arr, 1)
    
12.         s = Left(Sheets("Sheet2").Cells(i, 2), 1)
    
13.         d(s) = d(s) + 1
    
14.     Next
    
15.    
    
16.     i = 1
    
17.     For Each Key In d.keys
    
18.         Sheets("Sheet3").Cells(i + 10, 5).Value = Key
    
19.         Sheets("Sheet3").Cells(i + 10, 6).Value = d(Key)
    
20.         i = i + 1
    
21.     Next
    
22.    
    
23.     Set d = Nothing
    
24. 
    
25. End Sub
    

复制代码

lsc900707

上个代码稍作修改就行：

1吧吧

longwin 发表于 2024-8-16 10:53
Sub test()
    arr = Sheets("Sheet2").Range("B1:B9")
    Set d = CreateObject("scripting.dictionar ...

Sub test()
    arr = Sheets("Sheet2").Range("B1:B9")
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(Mid(arr(i, 1), 2, 1)) = d(Mid(arr(i, 1), 2, 1)) + 1
    Next
    Sheets("Sheet3").Range("B1:C" & d.Count) = WorksheetFunction.Transpose(Array(d.keys, d.items))
    Set d = Nothing
End Sub

这个改 d(Mid(arr(i, 1), 2, 1)) = d(Mid(arr(i, 1), 2, 1)) + 1
测试结果不对

1吧吧

1吧吧

第1行   1 1   到上面了

1吧吧

Sub test()
    arr = Sheets("Sheet2").Range("B1:B9")
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(Mid(arr(i, 1), 2, 1)) = d(Mid(arr(i, 1), 2, 1)) + 1
        d(Mid(arr(i, 1), 2, 1)) = d(Mid(arr(i, 1), 2, 1)) + 1
   

Next
    Sheets("Sheet3").Range("B1:C" & d.Count) = WorksheetFunction.Transpose(Array(d.keys, d.items))
    Sheets("Sheet3").Range("D1:E" & d.Count) = WorksheetFunction.Transpose(Array(d.keys, d.items))

Set d = Nothing
End Sub

1吧吧

Transpose(Arrayx
这个也限制了