ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12
返回列表 发新帖
楼主: geocm

[求助] 请求帮忙将依据设定的条件标准填入相应的分数

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-5-14 11:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

已将代码打入,运行时出现错误,不会如动图那样出结果。不知哪里的问题。请帮我看看。

模块.rar

889 Bytes, 下载次数: 1

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-5-14 11:32 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
719404338 发表于 2019-5-13 22:02
写了项目一的,【s2】、【m2】为前掷实心球

谢谢你,检测可行,EXCELHOME果然高手如云

TA的精华主题

TA的得分主题

发表于 2019-5-14 11:38 | 显示全部楼层
本帖最后由 不知道为什么 于 2019-5-14 16:05 编辑
geocm 发表于 2019-5-14 11:28
已将代码打入,运行时出现错误,不会如动图那样出结果。不知哪里的问题。请帮我看看。

111.zip (1.41 MB, 下载次数: 8)

TA的精华主题

TA的得分主题

发表于 2019-5-14 13:36 | 显示全部楼层
  1. Option Explicit
  2. Dim objItem As Object, objResult As Object
  3. Dim arrBoy_Jump As Variant, arrBoy_Ball As Variant, arrBoy_Rope As Variant, arrBoy_SitUp As Variant, arrBoy_Result As Variant
  4. Dim arrGril_Jump As Variant, arrGril_Ball As Variant, arrGril_Rope As Variant, arrGril_SitUp As Variant, arrGril_Result As Variant

  5. Sub Test()
  6.     Dim SH As Worksheet
  7.     Dim arrTemp As Variant, lngRow As Long
  8.     Dim strSex As String, strItem As String
  9.    
  10.     SetInfo '初始化
  11.    
  12.     Set SH = Sheets("Sheet1")
  13.     lngRow = SH.Range("A" & Rows.Count).End(xlUp).Row
  14.     arrTemp = SH.Range("A2:I" & lngRow)
  15.    
  16.     For lngRow = LBound(arrTemp) To UBound(arrTemp)
  17.         strSex = Trim(arrTemp(lngRow, 1)) '性别
  18.         strItem = Trim(arrTemp(lngRow, 2)) '项目
  19.         
  20.         Select Case UCase(Trim(strItem))
  21.             Case "A" 'A类  立定跳远 前掷实心球
  22.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Jump-" & strSex), objResult(strSex))
  23.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("Ball-" & strSex), objResult(strSex))
  24.             Case "B" 'B类  立定跳远    一分钟跳绳
  25.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Jump-" & strSex), objResult(strSex))
  26.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("Rope-" & strSex), objResult(strSex))
  27.             Case "C" 'C类 立定跳远    一分钟仰卧起坐
  28.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Jump-" & strSex), objResult(strSex))
  29.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("SitUp-" & strSex), objResult(strSex))
  30.             Case "D" 'D类 前掷实心球  一分钟跳绳
  31.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Ball-" & strSex), objResult(strSex))
  32.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("Rope-" & strSex), objResult(strSex))
  33.             Case "E" 'E类 前掷实心球  一分钟仰卧起坐
  34.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Ball-" & strSex), objResult(strSex))
  35.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("SitUp-" & strSex), objResult(strSex))
  36.             Case "F" 'F类 一分钟跳绳  一分钟仰卧起坐
  37.                 arrTemp(lngRow, 7) = GetInfo(Val(arrTemp(lngRow, 6)), objItem("Rope-" & strSex), objResult(strSex))
  38.                 arrTemp(lngRow, 9) = GetInfo(Val(arrTemp(lngRow, 8)), objItem("SitUp-" & strSex), objResult(strSex))
  39.         End Select
  40.     Next
  41.    
  42.     SH.Range("A2").Resize(UBound(arrTemp), 9) = arrTemp
  43. End Sub

  44. Function GetInfo(dblVal As Double, arrFind As Variant, arrResult As Variant) As String
  45.     If dblVal = 0 Then
  46.         GetInfo = ""
  47.     Else
  48.         GetInfo = Application.WorksheetFunction.Lookup(dblVal, arrFind, arrResult)
  49.     End If
  50. End Function

  51. Function SetInfo()
  52.     Dim SH_Boy As Worksheet, SH_Gril As Worksheet
  53.     Dim arrTemp As Variant, lngRow As Long, lngID As Long
  54.    
  55.     Set SH_Boy = Sheets("男生")
  56.     Set SH_Gril = Sheets("女生")
  57.    
  58.     '男生数据初始化
  59.     arrTemp = SH_Boy.Range("A2:E22")
  60.     lngRow = UBound(arrTemp)
  61.     ReDim arrBoy_Jump(0 To lngRow) As Double
  62.     ReDim arrBoy_Ball(0 To lngRow) As Double
  63.     ReDim arrBoy_Rope(0 To lngRow) As Double
  64.     ReDim arrBoy_SitUp(0 To lngRow) As Double
  65.     ReDim arrBoy_Result(0 To lngRow) As Double
  66.     lngID = 1
  67.     For lngRow = UBound(arrTemp) To LBound(arrTemp) Step -1
  68.         '升序排列,以便利用Lookup函数
  69.         arrBoy_Jump(lngID) = arrTemp(lngRow, 2) '立定跳远
  70.         arrBoy_Ball(lngID) = arrTemp(lngRow, 3) '掷实心球
  71.         arrBoy_Rope(lngID) = arrTemp(lngRow, 4) '一分钟跳绳
  72.         arrBoy_SitUp(lngID) = arrTemp(lngRow, 5) '一分钟仰卧起坐
  73.         arrBoy_Result(lngID) = arrTemp(lngRow, 1) '得分
  74.         lngID = lngID + 1
  75.     Next
  76.    
  77.      '女生数据初始化
  78.     arrTemp = SH_Gril.Range("A2:E22")
  79.     lngRow = UBound(arrTemp)
  80.     ReDim arrGril_Jump(0 To lngRow) As Double
  81.     ReDim arrGril_Ball(0 To lngRow) As Double
  82.     ReDim arrGril_Rope(0 To lngRow) As Double
  83.     ReDim arrGril_SitUp(0 To lngRow) As Double
  84.     ReDim arrGril_Result(0 To lngRow) As Double
  85.     lngID = 1
  86.     For lngRow = UBound(arrTemp) To LBound(arrTemp) Step -1
  87.         '升序排列,以便利用Lookup函数
  88.         arrGril_Jump(lngID) = arrTemp(lngRow, 2) '立定跳远
  89.         arrGril_Ball(lngID) = arrTemp(lngRow, 3) '掷实心球
  90.         arrGril_Rope(lngID) = arrTemp(lngRow, 4) '一分钟跳绳
  91.         arrGril_SitUp(lngID) = arrTemp(lngRow, 5) '一分钟仰卧起坐
  92.         arrGril_Result(lngID) = arrTemp(lngRow, 1) '得分
  93.         lngID = lngID + 1
  94.     Next
  95.    
  96.      Set objItem = CreateObject("Scripting.Dictionary")
  97.      Set objResult = CreateObject("Scripting.Dictionary")
  98.      
  99.      objResult("男") = arrBoy_Result
  100.      objResult("女") = arrGril_Result
  101.      
  102.      objItem("Jump-男") = arrBoy_Jump
  103.      objItem("Jump-女") = arrGril_Jump
  104.      objItem("Ball-男") = arrBoy_Ball
  105.      objItem("Ball-女") = arrGril_Ball
  106.      objItem("Rope-男") = arrBoy_Rope
  107.      objItem("Rope-女") = arrGril_Rope
  108.      objItem("SitUp-男") = arrBoy_SitUp
  109.      objItem("SitUp-女") = arrGril_SitUp
  110. End Function
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-5-14 13:52 | 显示全部楼层
代码审核中,上传附件了
寻找大师帮忙VBA.rar (63.35 KB, 下载次数: 1)

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-5-14 14:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

用F8调试运行时同样会出现相同的错误,为什么老师您的能得出结果,我的不行?

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-5-14 14:49 | 显示全部楼层
lsdongjh 发表于 2019-5-14 13:52
代码审核中,上传附件了

条条大路通罗马,谢谢,运行无错,现就差个免试和缺考,这个我自已应该能加。先试试。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-6-13 18:54 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 03:09 , Processed in 0.051023 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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