求一个自动统计代码，谢谢大家，初学者

2376803

想做一个自动统计分表人员获得评价的次数的代码。具体功能要求在附件里面
数据.rar (9.25 KB, 下载次数: 9)

2018-8-10 23:44 上传

点击文件名下载附件

qingc0221

1. Private Sub 统计_Click()
   
2.     Dim LastRow As Long, i As Long, m As Long, n As Long
   
3.     Dim d As Object
   
4.     Dim Arr, Result()
   
5.    
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     For Each sht In Worksheets
   
8.         If sht.Name <> Me.Name Then
   
9.             Arr = sht.Range("A1").CurrentRegion
   
10.             For i = 2 To UBound(Arr)
    
11.                 If d.Exists(Arr(i, 1)) = False Then
    
12.                     n = n + 1
    
13.                     d(Arr(i, 1)) = n
    
14.                     ReDim Preserve Result(1 To 5, 1 To n)
    
15.                     Result(1, n) = Arr(i, 1)
    
16.                     m = n
    
17.                 Else
    
18.                     m = d(Arr(i, 1))
    
19.                 End If
    
20.                 Result(Asc(Arr(i, 2)) - 63, m) = Result(Asc(Arr(i, 2)) - 63, m) + 1
    
21.             Next i
    
22.         End If
    
23.     Next sht
    
24.    
    
25.     LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
26.     If LastRow > 1 Then
    
27.         Range(Rows(2), Rows(LastRow)).Delete
    
28.     End If
    
29.     Range("A2").Resize(n, 5) = Application.Transpose(Result)
    
30.     Range("A1").CurrentRegion.Borders.Weight = xlThin
    
31. End Sub

复制代码

qingc0221

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

xiangbaoan

Sub test()
Dim d As Object, ar, br, r&, c%, y&, x%, sht As Worksheet
Set d = CreateObject("scripting.dictionary")
[a1].CurrentRegion.Offset(1, 1) = ""
ar = [a1].CurrentRegion
For r = 2 To UBound(ar)
    d(ar(r, 1)) = r
Next
For c = 2 To UBound(ar, 2)
    d(ar(1, c)) = c
Next
For Each sht In Sheets
    With sht
        If .Name <> "总表" Then
            br = .[a1].CurrentRegion
            For r = 2 To UBound(br)
                If d.exists(br(r, 1)) And d.exists(br(r, 2)) Then
                    y = d(br(r, 1))
                    x = d(br(r, 2))
                    ar(y, x) = ar(y, x) + 1
                End If
            Next
        End If
    End With
Next
[a1].CurrentRegion = ar
Set d = Nothing
End Sub

chaohuahch

代码如下：供测试：

1. Sub fyExcelVBA()
   
2. Dim arr, brr, i%, j%, str$
   
3. Dim dic As Object, sht As Worksheet
   
4. Set dic = CreateObject("scripting.dictionary")
   
5.   For Each sht In Worksheets
   
6.     If sht.Name <> "总表" Then
   
7.        arr = sht.Range("a1").CurrentRegion
   
8.        For i = 2 To UBound(arr)
   
9.         str = arr(i, 1) & arr(i, 2)
   
10.         If Not dic.exists(str) Then
    
11.            dic(str) = 1
    
12.          Else
    
13.            dic(str) = dic(str) + 1
    
14.          End If
    
15.        Next i
    
16.      End If
    
17.     Next
    
18. With Sheets("总表")
    
19. brr = .Range("a1").CurrentRegion
    
20.     For i = 2 To UBound(brr)
    
21.       For j = 2 To UBound(brr, 2)
    
22.       str = brr(i, 1) & brr(1, j)
    
23.       brr(i, j) = dic(str)
    
24.       Next j
    
25.     Next i
    
26.   .Range("a1").Resize(UBound(brr), UBound(brr, 2)).ClearContents
    
27.   .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28. End With
    
29. Set dic = Nothing
    
30. End Sub
    
31. 
    

复制代码

2376803

qingc0221 发表于 2018-8-11 05:28

谢谢大神，但是有个问题，就是我的总表里面评分不是固定不变的，我需要根据总编里面评分栏的变化，来统计分表的，简单的说就是我不只有ABCD的 可能还有A+ A-之类的，然后我在第一行修改A变成A+，然后就统计分变出现的A+。代码该如何修改呢，自己改了运行不来。

2376803

qingc0221 发表于 2018-8-11 05:28

谢谢大神，但是有个问题，就是我的总表里面评分不是固定不变的，我需要根据总编里面评分栏的变化，来统计分表的，简单的说就是我不只有ABCD的 可能还有A+ A-之类的，然后我在第一行修改A变成A+，然后就统计分变出现的A+。代码该如何修改呢，自己改了运行不来。

2376803

谢谢大神，但是有个问题，就是我的总表里面评分不是固定不变的，我需要根据总编里面评分栏的变化，来统计分表的，简单的说就是我不只有ABCD的 可能还有A+ A-之类的，然后我在第一行修改A变成A+，然后就统计分变出现的A+。代码该如何修改呢，自己改了运行不来。