Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2690|回复: 11

[已解决]求助,VB返回区域!

[复制链接]
发表于 2013-2-18 13:12 | 显示全部楼层 |阅读模式
先给大家拜个年!祝大家新年快乐,愿论坛更红火!


我需要将源数据表中的正考和补考不及格或缺考的提出来放在补考名单中,现在只能返回正考名单,能否将正考和补考不及格的都返回呢?或者更方便点直接将未参加补考的和补考不及格的名单筛选出来 补考名单提取.rar (46.35 KB, 下载次数: 5)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-2-18 13:41 | 显示全部楼层
  1. Sub 筛选数据()
  2.     Dim arr
  3.     Dim LastRow&, Record&
  4.     Dim i&, j&
  5.     Dim result()
  6.     Dim title()
  7.     title = Array("学号", "姓名", "课程", "正考", "补考")
  8.     With Worksheets("源数据")
  9.     LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
  10.     arr = .Range("a5:s" & LastRow)
  11.     End With
  12.     ReDim result(1 To 5, 1 To 1)
  13.     For i = LBound(arr) + 3 To UBound(arr)
  14.         For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
  15.             Debug.Print j
  16.             If arr(i, j) < 60 Or arr(i, j) = "缺" Then
  17.                 Record = Record + 1
  18.                 ReDim Preserve result(1 To 5, 1 To Record)
  19.                 result(1, Record) = "'" & arr(i, 2)
  20.                 result(2, Record) = arr(i, 3)
  21.                 result(3, Record) = arr(1, j)
  22.                 result(4, Record) = arr(i, j)
  23.                 If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
  24.                     result(5, Record) = arr(i, j + 1)
  25.                 End If
  26.             End If
  27.         Next
  28.     Next
  29.     With Worksheets("补考名单")
  30.         .Range("j2").Resize(Record, 5) = WorksheetFunction.Transpose(result)
  31.         .Range("j1").Resize(, 5) = title
  32.     End With
  33.     MsgBox "提取完成"
  34. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-18 13:41 | 显示全部楼层
结果要是符合要求的话,你改下输出位置就成了。
回复

使用道具 举报

发表于 2013-2-18 13:43 | 显示全部楼层
  1. Sub 筛选数据()
  2.     Dim arr
  3.     Dim LastRow&, Record&
  4.     Dim i&, j&
  5.     Dim result()
  6.     Dim title()
  7.     Application.ScreenUpdating = False
  8.     title = Array("学号", "姓名", "课程", "正考", "补考")
  9.     With Worksheets("源数据")
  10.         LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
  11.         arr = .Range("a5:s" & LastRow)
  12.     End With
  13.     ReDim result(1 To 5, 1 To 1)
  14.     For i = LBound(arr) + 3 To UBound(arr)
  15.         For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
  16.             If arr(i, j) < 60 Or arr(i, j) = "缺" Then
  17.                 Record = Record + 1
  18.                 ReDim Preserve result(1 To 5, 1 To Record)
  19.                 result(1, Record) = "'" & arr(i, 2)
  20.                 result(2, Record) = arr(i, 3)
  21.                 result(3, Record) = arr(1, j)
  22.                 result(4, Record) = arr(i, j)
  23.                 If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
  24.                     result(5, Record) = arr(i, j + 1)
  25.                 End If
  26.             End If
  27.         Next
  28.     Next
  29.     With Worksheets("补考名单")
  30.         .Range("j2").Resize(Record, 5) = WorksheetFunction.Transpose(result)
  31.         .Range("j1").Resize(, 5) = title
  32.         .Columns("j:n").AutoFit
  33.         .Columns("j:n").HorizontalAlignment = xlCenter
  34.     End With
  35.     Application.ScreenUpdating = True
  36.     MsgBox "提取完成"
  37. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-18 13:49 | 显示全部楼层    本楼为最佳答案   
  1. Sub 筛选数据2()
  2.     Dim arr
  3.     Dim LastRow&, Record&
  4.     Dim i&, j&
  5.     Dim result()
  6.     Dim title()
  7.     Application.ScreenUpdating = False
  8.     title = Array("学号", "姓名", "课程", "正考", "补考")
  9.     With Worksheets("源数据")
  10.         LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
  11.         arr = .Range("a5:s" & LastRow)
  12.     End With
  13.     ReDim result(1 To UBound(arr) * 8, 1 To 5)
  14.     For i = LBound(arr) + 3 To UBound(arr)
  15.         For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
  16.             If arr(i, j) < 60 Or arr(i, j) = "缺" Then
  17.                 Record = Record + 1
  18.                 result(Record, 1) = "'" & arr(i, 2)
  19.                 result(Record, 2) = arr(i, 3)
  20.                 result(Record, 3) = arr(1, j)
  21.                 result(Record, 4) = arr(i, j)
  22.                 If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
  23.                     result(Record, 5) = arr(i, j + 1)
  24.                 End If
  25.             End If
  26.         Next
  27.     Next
  28.     With Worksheets("补考名单")
  29.         .Range("j2").Resize(Record, 5) = result
  30.         .Range("j1").Resize(, 5) = title
  31.         .Columns("j:n").AutoFit
  32.         .Columns("j:n").HorizontalAlignment = xlCenter
  33.     End With
  34.     Application.ScreenUpdating = True
  35.     MsgBox "提取完成"
  36. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-18 13:58 | 显示全部楼层
For r = 4 To 20 Step 2

这就决定了你的计算结果只提取了正考的!!
回复

使用道具 举报

发表于 2013-2-18 14:00 | 显示全部楼层
结果输出到A:E列,两种方法均可行。
  1. Sub 筛选数据2()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 筛选数据2
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/2/18
  6. ' Purpose   : 静态数组
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim arr
  10.     Dim LastRow&, Record&
  11.     Dim i&, j&
  12.     Dim result()
  13.     Dim title()
  14.     Application.ScreenUpdating = False
  15.     title = Array("学号", "姓名", "课程", "正考", "补考")
  16.     With Worksheets("源数据")
  17.         LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
  18.         arr = .Range("a5:s" & LastRow)
  19.     End With
  20.     ReDim result(1 To UBound(arr) * 8, 1 To 5)
  21.     For i = LBound(arr) + 3 To UBound(arr)
  22.         For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
  23.             If arr(i, j) < 60 Or arr(i, j) = "缺" Then
  24.                 Record = Record + 1
  25.                 result(Record, 1) = "'" & arr(i, 2)
  26.                 result(Record, 2) = arr(i, 3)
  27.                 result(Record, 3) = arr(1, j)
  28.                 result(Record, 4) = arr(i, j)
  29.                 If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
  30.                     result(Record, 5) = arr(i, j + 1)
  31.                 End If
  32.             End If
  33.         Next
  34.     Next
  35.     With Worksheets("补考名单")
  36.         .Range("a1").CurrentRegion = ""
  37.         .Range("a2").Resize(Record, 5) = result
  38.         .Range("a1").Resize(, 5) = title
  39.         .Columns("a:e").AutoFit
  40.         .Columns("a:e").HorizontalAlignment = xlCenter
  41.     End With
  42.     Application.ScreenUpdating = True
  43.     MsgBox "提取完成"
  44. End Sub

  45. Sub 筛选数据()
  46. '---------------------------------------------------------------------------------------
  47. ' Procedure : 筛选数据
  48. ' Author    : hwc2ycy
  49. ' Date      : 2013/2/18
  50. ' Purpose   : 动态数组
  51. '---------------------------------------------------------------------------------------
  52. '
  53.     Dim arr
  54.     Dim LastRow&, Record&
  55.     Dim i&, j&
  56.     Dim result()
  57.     Dim title()
  58.     Application.ScreenUpdating = False
  59.     title = Array("学号", "姓名", "课程", "正考", "补考")
  60.     With Worksheets("源数据")
  61.         LastRow = .Cells(Rows.Count, "a").End(xlUp).Row
  62.         arr = .Range("a5:s" & LastRow)
  63.     End With
  64.     ReDim result(1 To 5, 1 To 1)
  65.     For i = LBound(arr) + 3 To UBound(arr)
  66.         For j = LBound(arr, 2) + 3 To UBound(arr, 2) - 1 Step 2
  67.             If arr(i, j) < 60 Or arr(i, j) = "缺" Then
  68.                 Record = Record + 1
  69.                 ReDim Preserve result(1 To 5, 1 To Record)
  70.                 result(1, Record) = "'" & arr(i, 2)
  71.                 result(2, Record) = arr(i, 3)
  72.                 result(3, Record) = arr(1, j)
  73.                 result(4, Record) = arr(i, j)
  74.                 If Len(arr(i, j + 1)) > 0 And arr(i, j + 1) < 60 Then
  75.                     result(5, Record) = arr(i, j + 1)
  76.                 End If
  77.             End If
  78.         Next
  79.     Next
  80.     With Worksheets("补考名单")
  81.         .Range("a1").CurrentRegion = ""
  82.         .Range("a2").Resize(Record, 5) = WorksheetFunction.Transpose(result)
  83.         .Range("a1").Resize(, 5) = title
  84.         .Columns("a:e").AutoFit
  85.         .Columns("a:e").HorizontalAlignment = xlCenter
  86.     End With
  87.     Application.ScreenUpdating = True
  88.     MsgBox "提取完成"
  89. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-18 14:00 | 显示全部楼层
补考名单提取2.rar (48.93 KB, 下载次数: 2)
回复

使用道具 举报

发表于 2013-2-18 14:08 | 显示全部楼层
无聊的疯子 发表于 2013-2-18 13:58
For r = 4 To 20 Step 2

这就决定了你的计算结果只提取了正考的!!

代码里你没看完,如果是正考缺考及不及格的,里面再测试补考的,{:3912:}
回复

使用道具 举报

发表于 2013-2-18 14:09 | 显示全部楼层
爱疯 发表于 2013-2-18 14:00
为什么源数据表的S列要隐藏啊

不想让我们看到,{:912:}
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 03:04 , Processed in 0.536190 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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