【完美解决】超多条件判断（特别感谢zhaogang1960、excelflower两位大师）

zhaogang1960 · 发表于 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

zhaogang1960 · 发表于 2011-3-2 22:16

附件

求助.rar (17.65 KB, 下载次数: 18)

puresway · 发表于 2011-3-2 22:21

原帖由 zhaogang1960 于 2011-3-2 22:16 发表
附件
881396

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

puresway · 发表于 2011-3-2 22:28

原帖由 zhaogang1960 于 2011-3-2 22:16 发表
附件
881396

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

excelflower · 发表于 2011-3-2 22:44

还有新要求没

http://club.excelhome.net/viewth ... =1255635#pid4679222

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

zhaogang1960 · 发表于 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

zhaogang1960 · 发表于 2011-3-2 22:56

附件

求助.rar (24.86 KB, 下载次数: 33)

puresway · 发表于 2011-3-2 23:02

完美解决！太感谢两位老师了，小弟不知该说什么好，谢谢你们，EH真好！谢谢！

excelflower · 发表于 2011-3-2 23:31

修正简化代码-自动级别.rar (15.87 KB, 下载次数: 52)

Private 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 Sheets("考核标准")
Brr = .Range("a1:d14")
End With
For i = 1 To UBound(Arr)
MyStrA = Arr(i, 1)
For j = 1 To UBound(Brr)
If MyStrA = Brr(j, 1) Then
If InStr(Arr(i, 1), "资深") And Arr(i, 2) >= 940 And Arr(i, 3) >= 470 Then
Arr(i, 9) = "维持资深"
Else
If Arr(i, 2) >= Brr(j - 1, 3) And Arr(i, 3) >= Brr(j - 1, 4) And j > 4 Then
Arr(i, 9) = "晋升两级：" & Brr(j - 2, 1)
ElseIf Arr(i, 2) >= Brr(j, 3) And Arr(i, 3) >= Brr(j, 4) And j > 3 Then
Arr(i, 9) = "晋升一级：" & Brr(j - 1, 1)
ElseIf j < 11 And (Arr(i, 2) >= Brr(j + 2, 3) And Arr(i, 3) >= Brr(j + 2, 4)) Then
Arr(i, 9) = "降一级：" & Brr(j + 1, 1)
ElseIf j = 10 And Arr(i, 2) < 120 And Arr(i, 3) < 70 Then
Arr(i, 9) = "降一级：" & Brr(j + 1, 1)
ElseIf j < 10 And (Arr(i, 2) < Brr(j + 2, 3) Or Arr(i, 3) < Brr(j + 2, 4)) Then
Arr(i, 9) = "降两级：" & Brr(j + 2, 1)
ElseIf j = 11 And Arr(i, 2) < 120 And Arr(i, 3) < 70 Then
Arr(i, 9) = "增加一个考核期后离职"
Else
Arr(i, 9) = "维持待晋"
End If
If j > 3 Then Arr(i, 6) = Arr(i, 3) - Brr(j, 4) '晋升一级差额
If j > 3 Then Arr(i, 5) = Arr(i, 2) - Brr(j, 3)
If j > 4 Then Arr(i, 8) = Arr(i, 3) - Brr(j - 1, 4) '晋升两级差额
If j > 4 Then Arr(i, 7) = Arr(i, 2) - Brr(j - 1, 3)
End If
Exit For
End If
Next j
Arr(i, 4) = Arr(i, 2) - Brr(j, 2) '维持差额
Next i
[c3].Resize(UBound(Arr), 9) = Arr
End Sub

复制代码

puresway · 发表于 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 ...

完美了，前辈，太感谢您了！谢谢您！嘿嘿

		自动登录	找回密码
密码			免费注册

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