ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 301|回复: 7

[求助] 求助如何用VBA代码实现

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-10 20:15 | 显示全部楼层 |阅读模式
各位大侠好!
      请教一下,如何将“开始”“结束”时间段内的有参数超上下限的项目名、当前值、上下限自动填进下面表格?
         - 如果该时间段内有多个数据超上下限,只取最大的超上下限的值
具体详见附件!!!

请教问题.zip

15.35 KB, 下载次数: 13

TA的精华主题

TA的得分主题

发表于 2020-1-10 20:21 | 显示全部楼层
这是数据透视么,不会,坐等高手

TA的精华主题

TA的得分主题

发表于 2020-1-10 20:35 | 显示全部楼层
循环对比,超限的再与已存在的超限数对比,取最大值

TA的精华主题

TA的得分主题

发表于 2020-1-11 07:15 | 显示全部楼层
'象是一组过程检测数据,怎么会有上限比下限小的?简单做了下处理,,,

Option Explicit

Sub test()
  Dim arr, mark, i, j, m, t, p1, p2, a, b
  mark = [h7].CurrentRegion
  arr = [p7].CurrentRegion
  ReDim brr(1 To 2 * UBound(arr, 2), 1 To 5)
  For i = 2 To UBound(mark, 1)
    If mark(i, 2) < mark(i, 3) Then t = mark(i, 2): mark(i, 2) = mark(i, 3): mark(i, 3) = t
  Next
  For j = 2 To UBound(arr, 2)
    p1 = 0: p2 = 0
    For i = 2 To UBound(arr, 1)
      If arr(i, j) > mark(j, 2) Then
        If p1 > 0 Then
          If arr(i, j) > a Then p1 = i: a = arr(i, j)
        Else
          p1 = i: a = arr(i, j)
        End If
      End If
      If arr(i, j) < mark(j, 3) Then
        If p2 > 0 Then
          If arr(i, j) < b Then p2 = i: b = arr(i, j)
        Else
          p2 = i: b = arr(i, j)
        End If
      End If
    Next
    If p1 > 0 Then
      m = m + 1
      brr(m, 1) = arr(1, j): brr(m, 2) = arr(p1, 1): brr(m, 3) = arr(p1, j): brr(m, 4) = mark(j, 2)
    End If
    If p2 > 0 Then
      m = m + 1
      brr(m, 1) = arr(1, j): brr(m, 2) = arr(p2, 1): brr(m, 3) = arr(p2, j): brr(m, 5) = mark(j, 3)
    End If
  Next
  [b22].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

评分

参与人数 3鲜花 +8 收起 理由
达州张先生 + 3 太强大了
LSYYLW + 2 太强大了
YZC51 + 3 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-12 09:18 | 显示全部楼层
一把小刀闯天下 发表于 2020-1-11 07:15
'象是一组过程检测数据,怎么会有上限比下限小的?简单做了下处理,,,

Option Explicit

哦,那个写错了,试了一下,能实现,多谢指教!!!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 18:42 | 显示全部楼层
一把小刀闯天下 发表于 2020-1-11 07:15
'象是一组过程检测数据,怎么会有上限比下限小的?简单做了下处理,,,

Option Explicit

好!还有一点,怎么根据开始时间至结束时间这段时间内参数是否超上下限?而不是全部数据

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 19:04 | 显示全部楼层
还有,参数打乱顺序就不对了,与上下限对不上了。

TA的精华主题

TA的得分主题

发表于 2020-1-14 10:52 | 显示全部楼层
Option Explicit

Sub test()
  Dim arr, i, j, m, t, p1, p2, a, b, tm(1), dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [h7].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If arr(i, 2) < arr(i, 3) Then t = arr(i, 2): arr(i, 2) = arr(i, 3): arr(i, 3) = t
    dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
  Next
  arr = [p7].CurrentRegion
  ReDim brr(1 To 2 * UBound(arr, 2), 1 To 5)
  tm(0) = [p8].Value '开始时间,指定单元格
  tm(1) = Cells([p8].End(xlDown).Row, "p").Value '结束时间,指定单元格
  For j = 2 To UBound(arr, 2)
    If dic.exists(arr(1, j)) Then
      p1 = 0: p2 = 0
      For i = 2 To UBound(arr, 1)
        If arr(i, 1) >= tm(0) And arr(i, 1) <= tm(1) Then
          If arr(i, j) > dic(arr(1, j))(0) Then
            If p1 > 0 Then
              If arr(i, j) > a Then p1 = i: a = arr(i, j)
            Else
              p1 = i: a = arr(i, j)
            End If
          End If
          If arr(i, j) < dic(arr(1, j))(1) Then
            If p2 > 0 Then
              If arr(i, j) < b Then p2 = i: b = arr(i, j)
            Else
              p2 = i: b = arr(i, j)
            End If
          End If
        End If
      Next
      If p1 > 0 Then
        m = m + 1
        brr(m, 1) = arr(1, j): brr(m, 2) = arr(p1, 1)
        brr(m, 3) = arr(p1, j): brr(m, 4) = dic(arr(1, j))(0)
      End If
      If p2 > 0 Then
        m = m + 1
        brr(m, 1) = arr(1, j): brr(m, 2) = arr(p2, 1)
        brr(m, 3) = arr(p2, j): brr(m, 5) = dic(arr(1, j))(1)
      End If
    Else
      MsgBox arr(1, j)
    End If
  Next
  [b22].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

评分

参与人数 2鲜花 +5 收起 理由
ljw1322 + 2 太强大了
YZC51 + 3 太强大了

查看全部评分

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

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2020-4-1 08:52 , Processed in 0.077018 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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