|

楼主 |
发表于 2024-1-22 18:55
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 测试()
Application.ScreenUpdating = False '停止屏幕刷新
On Error Resume Next
Dim arr As Variant, i, j As Integer
With Sheets("班级赋分")
arow = .Cells(Rows.Count, 1).End(xlUp).Row '找到A列最后一个有数据单元格的行号
arr = Range("A2:aj" & arow) '把单元格区域装入数组
Set d = CreateObject("scripting.dictionary") '创建
For j = 4 To 14
For i = 2 To UBound(arr, 1) '遍历数组arr1的一维
xm = arr(i, j)
If xm = "" Then '跳过空格
Else
Dim brr(200, 300)
If Not d.exists(xm) Then
d.Add xm, 1
brr(d.Count - 1, 0) = arr(i, 1) & arr(i, 2) '年级班级
brr(d.Count - 1, 1) = arr(i, j + 11) 'A
brr(d.Count - 1, 2) = arr(i, j + 22) 'B
Else
d(xm) = d(xm) + 1
cs = d(xm)
brr(cs, (cs - 1) * 3 + 1) = arr(i, 1) & arr(i, 2) '年级班级
brr(cs, (cs - 1) * 3 + 2) = arr(i, j + 11) 'A
brr(cs, (cs - 1) * 3 + 3) = arr(i, j + 22) 'B
End If
End If
Next
Next
End With
With Sheets("测试")
.[b2:c2000].ClearContents
.[b2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
.[c2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
.[f2].Resize(d.Count, 3) = brr
End With
Set d = Nothing '释放字典变量所占内存空间
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub
只能写入第一次,想把名字重复的3个数据依次写入brr中,怎么实现,主要是brr的一维卡起了,不能对应到相应的姓名处。
目前的设想是第一次出现在x行的0.1.2三列,第二次出现在x行的3.4.5,依次类推,最后显示出来 |
|