根据条件判断得分

翁知江安

供参考，欢迎批评指正

grayw

翁知江安 发表于 2025-4-15 13:50
供参考，欢迎批评指正

谢谢大虾回复~

翁知江安

Sub test250415()
Dim ar, br, cr As Variant, i, m, n, s, t, p, mm As Integer, d1, d2  As Object, kk, x
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Sheets("Sheet1").UsedRange
For i = 2 To UBound(ar)
    d1(ar(i, 1) & ar(i, 2)) = d1(ar(i, 1) & ar(i, 2)) + 1
    d2(ar(i, 1) & ar(i, 2) & "," & d1(ar(i, 1) & ar(i, 2))) = ar(i, 7)
Next
kk = "网格人员、经理、社会人员"
br = Sheets("评价").Range("a1:c" & Sheets("评价").[c65536].End(xlUp).Row)
For i = 2 To UBound(br)
   For n = 1 To d1(br(i, 1) & br(i, 2))
      s = d2(br(i, 1) & br(i, 2) & "," & n)
      t = Len(s) - Len(WorksheetFunction.Substitute(s, "、", ""))
      If t = 2 Then
         cr = Split(s, "、")
         For Each x In cr
            If InStr(kk, x) > 0 Then
              m = m + 1
            End If
         Next
         If m = 3 Then
            p = 0: m = 0: mm = mm + p
         Else
            p = 1: m = 0: mm = mm + p
         End If
      End If
    Next
    br(i, 3) = IIf(mm >= 1, 10, 0)
    mm = 0
Next
Sheets("评价").[a1].Resize(UBound(br), UBound(br, 2)) = br
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正。

翁知江安

前后两个基本上一致，后面的感觉简洁一些。

翁知江安

Sub test250415()
Dim ar, br, cr As Variant, i, m, n, s, t As Integer, d1, d2 As Object, x, kk
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Sheets("Sheet1").UsedRange
For i = 2 To UBound(ar)
    d1(ar(i, 1) & ar(i, 2)) = d1(ar(i, 1) & ar(i, 2)) + 1
    d2(ar(i, 1) & ar(i, 2) & "," & d1(ar(i, 1) & ar(i, 2))) = ar(i, 7)
Next
kk = "网格人员、经理、社会人员"
Sheets("评价").[c2].Resize(100, 1).ClearContents
br = Sheets("评价").Range("a1:c" & Sheets("评价").[b65536].End(xlUp).Row)
For i = 2 To UBound(br)
   For n = 1 To d1(br(i, 1) & br(i, 2))
      s = d2(br(i, 1) & br(i, 2) & "," & n)
      t = Len(s) - Len(WorksheetFunction.Substitute(s, "、", ""))
      If t = 2 Then
         cr = Split(s, "、")
         For Each x In cr
            If InStr(kk, x) > 0 Then
              m = m + 1
            End If
         Next
         If m <> 3 Then
            br(i, 3) = 10: Exit For
         End If
      End If
    Next
    If br(i, 3) = "" Then br(i, 3) = 0
Next
Sheets("评价").[a1].Resize(UBound(br), UBound(br, 2)) = br
MsgBox "ok"
End Sub

翁知江安

再次进行完善，希望能提高效率

grayw

翁知江安 发表于 2025-4-17 08:39
再次进行完善，希望能提高效率

谢谢大虾回复~

awen7878

Sub pingjia()
    Const b1 As String = "网格人员"
    Const b2 As String = "QA"
    Const b3 As String = "经理"
    Const b4 As String = "社会人员"
    Dim ar, br, cr, dr
    Dim ws As Worksheet
    Dim h, i, s, t As Long
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
        h = .Range("a" & .Rows.Count).End(xlUp).Row
        ar = .Range("b2:g" & h)
    End With
    With Sheets("评价")
        i = .Range("b" & .Rows.Count).End(xlUp).Row
        br = .Range("b3:b" & i)
    End With
    For s = LBound(br, 1) To UBound(br, 1)
        If Not dic.exists(br(s, 1)) Then
            dic.Add br(s, 1), 0
        End If
    Next s
    For t = LBound(ar, 1) To UBound(ar, 1)
        If dic.exists(ar(t, 1)) Then
            cr = ar(t, 6)
            If InStr(cr, b1) > 0 And InStr(cr, b2) > 0 And InStr(cr, b3) > 0 Then
                dic(ar(t, 1)) = 10
            ElseIf InStr(cr, b1) > 0 And InStr(cr, b2) > 0 And InStr(cr, b4) > 0 Then
                dic(ar(t, 1)) = 10
            ElseIf InStr(cr, b3) > 0 And InStr(cr, b2) > 0 And InStr(cr, b4) > 0 Then
                dic(ar(t, 1)) = 10
            End If
        End If
    Next t
    ReDim dr(1 To dic.Count, 1 To 1)
    s = 1
    For Each Key In dic.keys
        dr(s, 1) = dic(Key)
        s = s + 1
    Next
    Sheets("评价").Range("c3:c" & i) = dr
End Sub