设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 请教大师，用vba提取百人榜名单
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1943|回复: 8

[已解决]请教大师，用vba提取百人榜名单

[复制链接]
发表于 2015-8-1 14:32 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 武林长风 于 2015-8-2 09:26 编辑

请教vba大师，点击按钮提取每个年级的百人榜到百人榜工作表。见附件。
最佳答案
月排行榜 / 总排行榜
dsmch
2015-8-2 05:37
把表1作为辅助表
  1. Sub Macro1()
  2. Application.ScreenUpdating = False
  3. s = 1: Sheet8.UsedRange.Clear
  4. Sheets(1).Activate
  5. For i = 2 To 7
  6.     ActiveSheet.UsedRange.Clear
  7.     Sheets(i).UsedRange.Copy ActiveSheet.[a1]
  8.     If i < 4 Then
  9.         [g1] = "总分": [h1] = "名次"
  10.         [G2] = "=SUM(E2:F2)"
  11.         [G2].AutoFill Range("g2:g" & Range("a65536").End(xlUp).Row)
  12.         [h2] = "=RANK(G2,G:G,0)"
  13.         [h2].AutoFill Range("h2:h" & Range("a65536").End(xlUp).Row)
  14.         Range("a1").CurrentRegion.Sort [G2], Order1:=xlDescending, Header:=xlGuess
  15.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  16.         n = [g:g].Find(Cells(101, "g"), searchdirection:=xlPrevious).Row
  17.         Range("a1:h" & n).Copy Sheet8.Cells(s, 1)
  18.     Else
  19.         [j1] = "总分": [k1] = "名次"
  20.         [J2] = "=SUM(E2:I2)"
  21.         [J2].AutoFill Range("J2:J" & Range("a65536").End(xlUp).Row)
  22.         [K2] = "=RANK(J2,J:J,0)"
  23.         [K2].AutoFill Range("K2:K" & Range("a65536").End(xlUp).Row)
  24.         Range("a1").CurrentRegion.Sort [J2], Order1:=xlDescending, Header:=xlGuess
  25.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  26.         n = [J:J].Find(Cells(101, "j"), searchdirection:=xlPrevious).Row
  27.         Range("a1:k" & n).Copy Sheet8.Cells(s, 1)
  28.     End If
  29.     Sheet8.Cells(s, 1).CurrentRegion.Borders.LineStyle = xlContinuous
  30.     s = Sheet8.Range("a65536").End(xlUp).Row + 2
  31. Next
  32. ActiveSheet.UsedRange.Clear
  33. Sheet8.Activate
  34. Application.ScreenUpdating = True
  35. End Sub
复制代码

新建文件夹.rar

276.68 KB, 下载次数: 16
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2015-8-1 15:44 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
1楼附件已更新。
回复

使用道具 举报

dsmch
发表于 2015-8-1 16:26 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 dsmch 于 2015-8-1 16:30 编辑
  1. Sub Macro1()
  2. Application.ScreenUpdating = False
  3. s = 1: Sheet8.UsedRange.Clear
  4. For i = 2 To 7
  5.     Sheets(i).Activate
  6.     If i < 4 Then
  7.         [g1] = "总分": [h1] = "名次"
  8.         [G2] = "=SUM(E2:F2)"
  9.         [G2].AutoFill Range("g2:g" & Range("a65536").End(xlUp).Row)
  10.         [h2] = "=RANK(G2,G:G,0)"
  11.         [h2].AutoFill Range("h2:h" & Range("a65536").End(xlUp).Row)
  12.         Range("a1").CurrentRegion.Sort [G2], Order1:=xlDescending, Header:=xlGuess
  13.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  14.         n = [g:g].Find(Cells(101, "g"), searchdirection:=xlPrevious).Row
  15.         Range("a1:h" & n).Copy Sheet8.Cells(s, 1)
  16.     Else
  17.         [j1] = "总分": [k1] = "名次"
  18.         [J2] = "=SUM(E2:I2)"
  19.         [J2].AutoFill Range("J2:J" & Range("a65536").End(xlUp).Row)
  20.         [K2] = "=RANK(J2,J:J,0)"
  21.         [K2].AutoFill Range("K2:K" & Range("a65536").End(xlUp).Row)
  22.         Range("a1").CurrentRegion.Sort [J2], Order1:=xlDescending, Header:=xlGuess
  23.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  24.         n = [J:J].Find(Cells(101, "j"), searchdirection:=xlPrevious).Row
  25.         Range("a1:k" & n).Copy Sheet8.Cells(s, 1)
  26.     End If
  27.     s = Sheet8.Range("a65536").End(xlUp).Row + 2
  28. Next
  29. Sheet8.Activate
  30. Application.ScreenUpdating = True
  31. End Sub
复制代码
开启工具、选项、重新计算、自动重算
回复

使用道具 举报

 楼主| 发表于 2015-8-1 16:30 | 显示全部楼层
dsmch 发表于 2015-8-1 16:26
开启工具、选项、重新计算、自动重算

QQ截图20150801162601.png
回复

使用道具 举报

dsmch
发表于 2015-8-1 16:36 | 显示全部楼层
………………

成绩单（百人榜）_1.zip

336.26 KB, 下载次数: 28
回复

使用道具 举报

 楼主| 发表于 2015-8-1 16:42 | 显示全部楼层
dsmch 发表于 2015-8-1 16:36
………………

哦，取消了强制声明。可否再修改一下代码，总分、名次加上边框线。谢谢！
回复

使用道具 举报

 楼主| 发表于 2015-8-1 16:45 | 显示全部楼层
本帖最后由 武林长风 于 2015-8-1 16:46 编辑
dsmch 发表于 2015-8-1 16:36
………………

忘了说了，请不要对1-6年级成绩单工作表做任何改动。

点评

dsmch
不改动工作表比较麻烦，先备份吧。  发表于 2015-8-1 16:53
回复

使用道具 举报

dsmch
发表于 2015-8-1 16:51 | 显示全部楼层
Sub Macro1()
Application.ScreenUpdating = False
s = 1: Sheet8.UsedRange.Clear
For i = 2 To 7
    Sheets(i).Activate
    If i < 4 Then
        [g1] = "总分": [h1] = "名次"
        [G2] = "=SUM(E2:F2)"
        [G2].AutoFill Range("g2:g" & Range("a65536").End(xlUp).Row)
        [h2] = "=RANK(G2,G:G,0)"
        [h2].AutoFill Range("h2:h" & Range("a65536").End(xlUp).Row)
        Range("a1").CurrentRegion.Sort [G2], Order1:=xlDescending, Header:=xlGuess
        Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
        n = [g:g].Find(Cells(101, "g"), searchdirection:=xlPrevious).Row
        Range("a1:h" & n).Copy Sheet8.Cells(s, 1)
    Else
        [j1] = "总分": [k1] = "名次"
        [J2] = "=SUM(E2:I2)"
        [J2].AutoFill Range("J2:J" & Range("a65536").End(xlUp).Row)
        [K2] = "=RANK(J2,J:J,0)"
        [K2].AutoFill Range("K2:K" & Range("a65536").End(xlUp).Row)
        Range("a1").CurrentRegion.Sort [J2], Order1:=xlDescending, Header:=xlGuess
        Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
        n = [J:J].Find(Cells(101, "j"), searchdirection:=xlPrevious).Row
        Range("a1:k" & n).Copy Sheet8.Cells(s, 1)
    End If
    Sheet8.Cells(s, 1).CurrentRegion.Borders.LineStyle = xlContinuous
    s = Sheet8.Range("a65536").End(xlUp).Row + 2
Next
Sheet8.Activate
Application.ScreenUpdating = True
End Sub

点评

武林长风
若工作表改动了，其它的计算如及格人数、优秀人数等就乱了。  发表于 2015-8-1 17:03
回复

使用道具 举报

dsmch
发表于 2015-8-2 05:37 | 显示全部楼层    本楼为最佳答案   
把表1作为辅助表
  1. Sub Macro1()
  2. Application.ScreenUpdating = False
  3. s = 1: Sheet8.UsedRange.Clear
  4. Sheets(1).Activate
  5. For i = 2 To 7
  6.     ActiveSheet.UsedRange.Clear
  7.     Sheets(i).UsedRange.Copy ActiveSheet.[a1]
  8.     If i < 4 Then
  9.         [g1] = "总分": [h1] = "名次"
  10.         [G2] = "=SUM(E2:F2)"
  11.         [G2].AutoFill Range("g2:g" & Range("a65536").End(xlUp).Row)
  12.         [h2] = "=RANK(G2,G:G,0)"
  13.         [h2].AutoFill Range("h2:h" & Range("a65536").End(xlUp).Row)
  14.         Range("a1").CurrentRegion.Sort [G2], Order1:=xlDescending, Header:=xlGuess
  15.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  16.         n = [g:g].Find(Cells(101, "g"), searchdirection:=xlPrevious).Row
  17.         Range("a1:h" & n).Copy Sheet8.Cells(s, 1)
  18.     Else
  19.         [j1] = "总分": [k1] = "名次"
  20.         [J2] = "=SUM(E2:I2)"
  21.         [J2].AutoFill Range("J2:J" & Range("a65536").End(xlUp).Row)
  22.         [K2] = "=RANK(J2,J:J,0)"
  23.         [K2].AutoFill Range("K2:K" & Range("a65536").End(xlUp).Row)
  24.         Range("a1").CurrentRegion.Sort [J2], Order1:=xlDescending, Header:=xlGuess
  25.         Range("a1").CurrentRegion = Range("a1").CurrentRegion.Value
  26.         n = [J:J].Find(Cells(101, "j"), searchdirection:=xlPrevious).Row
  27.         Range("a1:k" & n).Copy Sheet8.Cells(s, 1)
  28.     End If
  29.     Sheet8.Cells(s, 1).CurrentRegion.Borders.LineStyle = xlContinuous
  30.     s = Sheet8.Range("a65536").End(xlUp).Row + 2
  31. Next
  32. ActiveSheet.UsedRange.Clear
  33. Sheet8.Activate
  34. Application.ScreenUpdating = True
  35. End Sub
复制代码

评分

参与人数 1 +9 收起 理由
武林长风 + 9 很给力!

查看全部评分

回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 04:40 , Processed in 0.603746 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表