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

zhaogang1960

原帖由 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

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

2011-3-2 22:16 上传

点击文件名下载附件

puresway

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

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

puresway

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

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

excelflower

还有新要求没 http://club.excelhome.net/viewth ... =1255635#pid4679222

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

zhaogang1960

原帖由 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

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

2011-3-2 22:56 上传

点击文件名下载附件

puresway

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

excelflower

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

2011-3-2 23:31 上传

点击文件名下载附件

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

复制代码

puresway

原帖由 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 ...

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