ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: puresway

[已解决] 【完美解决】超多条件判断(特别感谢zhaogang1960、excelflower两位大师)

[复制链接]

TA的精华主题

TA的得分主题

发表于 2011-3-2 22:15 | 显示全部楼层
原帖由 puresway 于 2011-3-2 21:59 发表

比如说第14行常文强总指标35,中二级要维持的话需达到160,所以他要待维持,并且他的总指标还低于他的下一级即中一级维持所要达到的120,鉴于只能最多降两级,判断到此结束。所以他应是“待维持:降两级”。另外, ...

Sub Macro1()
    Dim d As Object, arr, brr, crr(), i&, r&
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("考核标准").Range("A1").CurrentRegion
    For i = 3 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    brr = Range("C3:E" & Range("C65536").End(xlUp).Row)
    ReDim crr(1 To UBound(brr), 1 To 6)
    For i = 1 To UBound(brr)
        If d.Exists(brr(i, 1)) Then
            r = d(brr(i, 1))
            If brr(i, 2) >= arr(r, 2) Then
                If brr(i, 2) >= Val(arr(r - 1, 3)) And brr(i, 3) >= Val(arr(r - 1, 4)) Then
                    If r >= 5 Then
                        crr(i, 6) = "晋升两级"
                    Else
                        crr(i, 6) = "维持" & Left(brr(i, 1), 2)
                    End If
                ElseIf brr(i, 2) >= Val(arr(r, 3)) And brr(i, 3) >= Val(arr(r, 4)) Then
                    If r >= 4 Then
                        crr(i, 6) = "晋升一级"
                        crr(i, 4) = brr(i, 2) - arr(r - 1, 3)
                        crr(i, 5) = brr(i, 3) - arr(r - 1, 4)
                    Else
                        crr(i, 6) = "维持" & Left(arr(i, 1), 2)
                    End If
                Else
                    crr(i, 6) = "维持待晋"
                    crr(i, 2) = brr(i, 2) - arr(r, 3)
                    crr(i, 3) = brr(i, 3) - arr(r, 4)
                End If
            Else
                crr(i, 1) = brr(i, 2) - arr(r, 2)
                If r < 10 Then
                    If brr(i, 2) <= arr(r + 1, 2) Then
                        crr(i, 6) = "待维持:目前降两级"
                    Else
                        crr(i, 6) = "待维持:目前降一级"
                    End If
                ElseIf r = 10 Then
                    If brr(i, 2) <= arr(r + 1, 2) Then crr(i, 6) = "待维持:目前降一级"
                Else
                    crr(i, 6) = "待维持"
                End If
            End If
        End If
    Next
    Range("f3").Resize(i - 1, 6) = crr
End Sub

TA的精华主题

TA的得分主题

发表于 2011-3-2 22:16 | 显示全部楼层
附件
求助.rar (17.65 KB, 下载次数: 18)

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-3-2 22:21 | 显示全部楼层
原帖由 zhaogang1960 于 2011-3-2 22:16 发表
附件
881396

就是这个效果,太感谢您了,赵老师,您真是俺的偶像 嘿嘿 谢谢 谢谢

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-3-2 22:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
原帖由 zhaogang1960 于 2011-3-2 22:16 发表
附件
881396

赵老师,能不能再麻烦您在备注(K列)后面(L列)加上“目前达到职级”啊,谢谢

求助.rar

21.26 KB, 下载次数: 2

TA的精华主题

TA的得分主题

发表于 2011-3-2 22:44 | 显示全部楼层
还有新要求没 http://club.excelhome.net/viewth ... =1255635#pid4679222

[ 本帖最后由 excelflower 于 2011-3-2 23:43 编辑 ]

TA的精华主题

TA的得分主题

发表于 2011-3-2 22:53 | 显示全部楼层
原帖由 puresway 于 2011-3-2 22:28 发表

赵老师,能不能再麻烦您在备注(K列)后面(L列)加上“目前达到职级”啊,谢谢

Sub Macro1()
    Dim d As Object, arr, brr, crr(), i&, r&
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("考核标准").Range("A1").CurrentRegion
    For i = 3 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    brr = Range("C3:E" & Range("C65536").End(xlUp).Row)
    ReDim crr(1 To UBound(brr), 1 To 7)
    For i = 1 To UBound(brr)
        If d.Exists(brr(i, 1)) Then
            r = d(brr(i, 1))
            If brr(i, 2) >= arr(r, 2) Then
                If brr(i, 2) >= Val(arr(r - 1, 3)) And brr(i, 3) >= Val(arr(r - 1, 4)) Then
                    If r >= 5 Then
                        crr(i, 6) = "晋升两级"
                        crr(i, 7) = arr(r - 2, 1)
                    Else
                        crr(i, 6) = "维持" & Left(brr(i, 1), 2)
                        crr(i, 7) = brr(i, 1)
                    End If
                ElseIf brr(i, 2) >= Val(arr(r, 3)) And brr(i, 3) >= Val(arr(r, 4)) Then
                    If r >= 4 Then
                        crr(i, 6) = "晋升一级"
                        crr(i, 4) = brr(i, 2) - arr(r - 1, 3)
                        crr(i, 5) = brr(i, 3) - arr(r - 1, 4)
                        crr(i, 7) = arr(r - 1, 1)
                    Else
                        crr(i, 6) = "维持" & Left(arr(i, 1), 2)
                        
                    End If
                Else
                    crr(i, 6) = "维持待晋"
                    crr(i, 2) = brr(i, 2) - arr(r, 3)
                    crr(i, 3) = brr(i, 3) - arr(r, 4)
                    crr(i, 7) = brr(i, 1)
                End If
            Else
                crr(i, 1) = brr(i, 2) - arr(r, 2)
                If r < 10 Then
                    If brr(i, 2) <= arr(r + 1, 2) Then
                        crr(i, 6) = "待维持:目前降两级"
                        crr(i, 7) = arr(r + 2, 1)
                    Else
                        crr(i, 6) = "待维持:目前降一级"
                        crr(i, 7) = arr(r + 1, 1)
                    End If
                ElseIf r = 10 Then
                    If brr(i, 2) <= arr(r + 1, 2) Then
                        crr(i, 6) = "待维持:目前降一级"
                        crr(i, 7) = arr(r + 1, 1)
                    End If
                Else
                    crr(i, 6) = "待维持:增加一个考核期后离职"
                    crr(i, 7) = brr(i, 1)
                End If
            End If
        End If
    Next
    Range("f3").Resize(i - 1, 7) = crr
End Sub

TA的精华主题

TA的得分主题

发表于 2011-3-2 22:56 | 显示全部楼层
附件
求助.rar (24.86 KB, 下载次数: 33)

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-3-2 23:02 | 显示全部楼层
完美解决!太感谢两位老师了,小弟不知该说什么好,谢谢你们,EH真好!谢谢!

TA的精华主题

TA的得分主题

发表于 2011-3-2 23:31 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
修正简化代码-自动级别.rar (15.87 KB, 下载次数: 52)
  1. Private Sub CommandButton1_Click()
  2.     Dim i&, j&, Arr, Brr, MyStrA$, MyNum&
  3.     Range("f3:k" & [a65536].End(3).Row) = "" '清除原有内容
  4.     Arr = Range("c3:k" & [a65536].End(3).Row)
  5.     With Sheets("考核标准")
  6.         Brr = .Range("a1:d14")
  7.     End With
  8.     For i = 1 To UBound(Arr)
  9.         MyStrA = Arr(i, 1)
  10.         For j = 1 To UBound(Brr)
  11.             If MyStrA = Brr(j, 1) Then
  12.                 If InStr(Arr(i, 1), "资深") And Arr(i, 2) >= 940 And Arr(i, 3) >= 470 Then
  13.                     Arr(i, 9) = "维持资深"
  14.                 Else
  15.                     If Arr(i, 2) >= Brr(j - 1, 3) And Arr(i, 3) >= Brr(j - 1, 4) And j > 4 Then
  16.                         Arr(i, 9) = "晋升两级:" & Brr(j - 2, 1)
  17.                     ElseIf Arr(i, 2) >= Brr(j, 3) And Arr(i, 3) >= Brr(j, 4) And j > 3 Then
  18.                         Arr(i, 9) = "晋升一级:" & Brr(j - 1, 1)
  19.                     ElseIf j < 11 And (Arr(i, 2) >= Brr(j + 2, 3) And Arr(i, 3) >= Brr(j + 2, 4)) Then
  20.                         Arr(i, 9) = "降一级:" & Brr(j + 1, 1)
  21.                     ElseIf j = 10 And Arr(i, 2) < 120 And Arr(i, 3) < 70 Then
  22.                         Arr(i, 9) = "降一级:" & Brr(j + 1, 1)
  23.                     ElseIf j < 10 And (Arr(i, 2) < Brr(j + 2, 3) Or Arr(i, 3) < Brr(j + 2, 4)) Then
  24.                         Arr(i, 9) = "降两级:" & Brr(j + 2, 1)
  25.                     ElseIf j = 11 And Arr(i, 2) < 120 And Arr(i, 3) < 70 Then
  26.                         Arr(i, 9) = "增加一个考核期后离职"
  27.                     Else
  28.                         Arr(i, 9) = "维持待晋"
  29.                     End If
  30.                     If j > 3 Then Arr(i, 6) = Arr(i, 3) - Brr(j, 4) '晋升一级差额
  31.                     If j > 3 Then Arr(i, 5) = Arr(i, 2) - Brr(j, 3)
  32.                     If j > 4 Then Arr(i, 8) = Arr(i, 3) - Brr(j - 1, 4) '晋升两级差额
  33.                     If j > 4 Then Arr(i, 7) = Arr(i, 2) - Brr(j - 1, 3)
  34.                 End If
  35.                 Exit For
  36.             End If
  37.         Next j
  38.         Arr(i, 4) = Arr(i, 2) - Brr(j, 2) '维持差额
  39.     Next i
  40.     [c3].Resize(UBound(Arr), 9) = Arr
  41. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-3-3 00:05 | 显示全部楼层
原帖由 excelflower 于 2011-3-2 23:31 发表
881435Private Sub CommandButton1_Click()
    Dim i&, j&, Arr, Brr, MyStrA$, MyNum&
    Range("f3:k" & [a65536].End(3).Row) = "" '清除原有内容
    Arr = Range("c3:k" & [a65536].End(3).Row)
    With ...

完美了,前辈,太感谢您了!谢谢您!嘿嘿
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-12-12 12:38 , Processed in 0.052808 second(s), 6 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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