[已解决]如何使用vba合并数据

531tommy

我需要在Sheet2中提取成绩表的数据，并在Sheet2中合并排列

成绩列表.zip (15.08 KB, 下载次数: 8)

2021-10-3 15:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-10-3 17:45

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

祝順心，南無阿彌陀佛！

风林火山

1. Sub 导出成绩()
   
2.     Dim d, d1, arr, k As Integer, m As Byte, n As Byte, str
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("成绩表").Range("a1").CurrentRegion
   
6.     For k = 2 To UBound(arr)
   
7.         str = arr(k, 1) & "|" & arr(k, 2) & "|" & arr(k, 3)
   
8.         d1(str) = d1(str) + arr(k, 5)
   
9.         If Not d.exists(str) Then
   
10.             d(str) = arr(k, 4) & "/" & arr(k, 5)
    
11.         Else
    
12.             d(str) = d(str) & "、" & arr(k, 4) & "/" & arr(k, 5)
    
13.         End If
    
14.     Next k
    
15.     Erase arr
    
16.     ReDim Preserve arr(1 To d1.Count, 1 To 5)
    
17.     For k = 0 To d.Count - 1
    
18.         str = Split(d.keys()(k), "|")
    
19.         n = n + 1
    
20.         arr(n, 1) = str(0)
    
21.         arr(n, 2) = str(1)
    
22.         arr(n, 3) = str(2)
    
23.         arr(n, 4) = d(d.keys()(k))
    
24.         arr(n, 5) = d1(d1.keys()(k))
    
25.     Next k
    
26.     Sheets("导出成绩").Range("a2").Resize(UBound(arr), 5) = arr
    
27. End Sub

复制代码

531tommy

风林火山 发表于 2021-10-3 19:23

很感谢您啊，你的代码执行也是可以的，只是2楼的代码更加简便

风林火山

531tommy 发表于 2021-10-4 10:48
很感谢您啊，你的代码执行也是可以的，只是2楼的代码更加简便

我就是练习用，能帮上你就更好了。你不用这么客气。

zaalex

Sub test()
Dim dic As New Dictionary
Dim arr()
arr = Sheet1.Range("b2:b68")
For i = 1 To 67
    dic(arr(i, 1)) = 1
Next
For j = 1 To dic.Count
    Sheet2.Range("b" & j + 1) = dic.Keys(j - 1)
    Sheet2.Range("a" & j + 1) = Application.WorksheetFunction.Index(Sheet1.Range("a:a"), Application.WorksheetFunction.Match(Sheet2.Range("b" & j + 1), Sheet1.Range("b:b"), 0))
    Sheet2.Range("c" & j + 1) = Application.WorksheetFunction.VLookup(Sheet2.Range("b" & j + 1), Sheet1.Range("b2:e68"), 2, 0)
    k = ""
    For m = 1 To 67
        If Sheet2.Range("b" & j + 1) = Sheet1.Range("b" & m + 1) Then
        k = k & (Sheet1.Range("d" & m + 1) & "/" & Sheet1.Range("e" & m + 1)) & "、"
        End If
    Next
    Sheet2.Range("d" & j + 1) = VBA.Left(k, Len(k) - 1)
    Sheet2.Range("e" & j + 1) = Application.WorksheetFunction.SumIf(Sheet1.Range("b:b"), Sheet2.Range("b" & j + 1), Sheet1.Range("e:e"))
Next
End Sub