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

puresway

原帖由 zhaogang1960 于 2011-3-2 22:53 发表

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)
   ...

赵老师，刚发现了个问题，中一级没有达到维持的那些，就是总指标介于中一级维持和初级维持的（应该是待维持：目前降一级，目前职级应是初级），没有判断是空白，该怎么修正呢？谢谢！

zhaogang1960

原帖由 puresway 于 2011-3-3 00:09 发表

赵老师，刚发现了个问题，中一级没有达到维持的那些，就是总指标介于中一级维持和初级维持的（应该是待维持：目前降一级，目前职级应是初级），没有判断是空白，该怎么修正呢？谢谢！

                ElseIf r = 10 Then
                    If brr(i, 2) <= arr(r, 2) Then'这里原来是r+1
                        crr(i, 6) = "待维持：目前降一级"
                        crr(i, 7) = arr(r + 1, 1)
                    End If
                Else
求助.rar (25.22 KB, 下载次数: 26)

2011-3-3 00:22 上传

点击文件名下载附件

puresway

原帖由 zhaogang1960 于 2011-3-3 00:22 发表

                ElseIf r = 10 Then
                    If brr(i, 2)  

解决了，谢谢赵老师，晚安！嘿嘿！

puresway

原帖由 zhaogang1960 于 2011-3-3 00:22 发表

                ElseIf r = 10 Then
                    If brr(i, 2)  

赵老师，小弟现在还有个问题，资深二级的维持和晋升好像有点问题，可能还是因为小弟的表述给老师造成误解了，资深二级应该可以晋升一级的，但不能晋升两级，因为到顶了，另外如果维持但不能晋的话，就写“维持待晋”，资深三级的维持才写“维持资深”。麻烦赵老师再改一下，谢谢！另外，能不能再请赵老师加个功能，就是点击按钮2，会按照第一列区域的地点自动在考核结果中生成以不同地方命名的文件如：郑州.xls,新密xls,.....格式和主表一样，内容是筛选后的不同地点的信息。谢谢赵老师

zhaogang1960

原帖由 puresway 于 2011-3-3 09:59 发表

赵老师，小弟现在还有个问题，资深二级的维持和晋升好像有点问题，可能还是因为小弟的表述给老师造成误解了，资深二级应该可以晋升一级的，但不能晋升两级，因为到顶了，另外如果维持但不能晋的话，就写“维持待晋 ...

先测试第一个要求：
Sub Macro1()
    Dim d As Object, arr, brr, crr(), i&, r&
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("考核标准").Range("A1").CurrentRegion
    arr(2, 3) = 10000: arr(2, 4) = 10000: arr(3, 3) = 10000: arr(3, 4) = 10000
    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) = "晋升一级"
                        If r > 4 Then crr(i, 4) = brr(i, 2) - arr(r - 1, 3)
                        If r > 4 Then crr(i, 5) = brr(i, 3) - arr(r - 1, 4)
                        crr(i, 7) = arr(r - 1, 1)
                    Else
                        crr(i, 6) = "维持" & Left(brr(i, 1), 2)
                        crr(i, 7) = brr(i, 1)
                    End If
                Else
                    crr(i, 6) = "维持待晋"
                    If r > 3 Then crr(i, 2) = brr(i, 2) - arr(r, 3)
                    If r > 3 Then 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, 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.78 KB, 下载次数: 18)

2011-3-3 10:49 上传

点击文件名下载附件

puresway

原帖由 zhaogang1960 于 2011-3-3 10:49 发表
附件
881605

赵老师，成功解决，谢谢您！

zhaogang1960

第二个问题：
Sub Macro2()
    Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&
    Set rng = Range("A1:l2")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 3 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 12)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 12))
        End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[A1]
            t(i).Copy .[A3]
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\考核结果\" & k(i) & ".xls"
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

zhaogang1960

附件
求助.rar (25.62 KB, 下载次数: 28)

2011-3-3 10:59 上传

点击文件名下载附件

puresway

原帖由 zhaogang1960 于 2011-3-3 10:59 发表
附件
881613

完美解决，太感谢您了赵老师，谢谢谢谢！