[已解决]根据数据向下填充

amzxfgh9632

要求附件内
根据数据向下填充完成.rar (12.01 KB, 下载次数: 17)

2014-12-28 01:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2014-12-28 10:32

1. Sub lqxs()
   
2. Dim Arr, i&, nj$, col, c&
   
3. Application.ScreenUpdating = False
   
4. Sheet2.Activate
   
5. [a2:o5000].ClearContents
   
6. nj = "一二三": col = Array(1, 6, 11)
   
7. Arr = Sheet1.[a1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     c = col(InStr(nj, Left(Arr(i, 2), 1)) - 1)
   
10.     For j = 1 To Arr(i, 3)
    
11.         n = Cells(Rows.Count, c).End(xlUp).Row + 1
    
12.         Cells(n, c) = Arr(i, 1): Cells(n, c + 1) = Arr(i, 2)
    
13.     Next
    
14. Next
    
15. Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

跳转到最佳答案楼层

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, nj$, col, c&
   
3. Application.ScreenUpdating = False
   
4. Sheet2.Activate
   
5. [a2:o5000].ClearContents
   
6. nj = "一二三": col = Array(1, 6, 11)
   
7. Arr = Sheet1.[a1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     c = col(InStr(nj, Left(Arr(i, 2), 1)) - 1)
   
10.     For j = 1 To Arr(i, 3)
    
11.         n = Cells(Rows.Count, c).End(xlUp).Row + 1
    
12.         Cells(n, c) = Arr(i, 1): Cells(n, c + 1) = Arr(i, 2)
    
13.     Next
    
14. Next
    
15. Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. ReDim brr(1 To 60000, 1 To 200)
   
7. n = -3
   
8. For i = 2 To UBound(arr)
   
9.     nj = Left(arr(i, 2), 3) '年级
   
10. If Not d2.exists(nj) Then n = n + 5: d2(nj) = n
    
11.     l = d2(nj) '列
    
12.     If Not d.exists(nj) Then
    
13.         d(nj) = arr(i, 3) + 1
    
14.         brr(1, l - 1) = "学校名称"
    
15.         brr(1, l) = nj
    
16.         brr(1, l + 1) = "姓名"
    
17.         brr(1, l + 2) = "语文"
    
18.         brr(1, l + 3) = "数学"
    
19.         For j = 1 To arr(i, 3)
    
20.             brr(1 + j, l - 1) = arr(i, 1)
    
21.             brr(1 + j, l) = arr(i, 2)
    
22.         Next
    
23.     Else
    
24.         h = d(nj) '行
    
25.         For j = 1 To arr(i, 3)
    
26.             brr(h + j, l - 1) = arr(i, 1)
    
27.             brr(h + j, l) = arr(i, 2)
    
28.         Next
    
29.         d(nj) = d(nj) + arr(i, 3)
    
30.     End If
    
31. Next
    
32. zdh = Application.Max(d.items) '最大行
    
33. zdl = Application.Max(d2.items) + 3 '最大列
    
34. Sheet2.Range("a1").Resize(zdh, zdl) = brr
    
35. End Sub

复制代码

dsmch

标题和数据根据源数据自动填充

amzxfgh9632

dsmch 发表于 2014-12-28 11:40
标题和数据根据源数据自动填充

谢谢了，完美解决，如果有什么问题还会再请教的，谢谢老师

amzxfgh9632

蓝桥玄霜 发表于 2014-12-28 10:32

有个小问题，清除的时候一起将姓名，科目成绩一起清除了，输到一半，如果不小心按到按钮哪要坐着哭了

amzxfgh9632

蓝桥玄霜 发表于 2014-12-28 10:32

麻烦版主再给改下，菜鸟，无招了
根据数据向下填充完成.rar (13.98 KB, 下载次数: 0)

2015-1-4 12:11 上传

点击文件名下载附件