来个比较难的给高手练练手

summerlcb

如附件，谢谢

lsc900707

代码放模块里，按钮在“合格名单”工作表：
Sub lsc()
    Set d = CreateObject("scripting.dictionary")
    For Each sht In Sheets
         If sht.Name <> ActiveSheet.Name Then
              With sht
                   arr = .UsedRange
                   For i = 3 To UBound(arr)
                        For j = 2 To UBound(arr, 2)
                             If arr(i, j) = "√" Then
                                 d(arr(i, 1)) = d(arr(i, 1)) + 1
                             End If
                        Next
                    Next
             End With
         End If
    Next
    t = d.keys
    ReDim brr(1 To UBound(t), 1 To 1)
    For i = 0 To UBound(t)
        If d(t(i)) >= 2 Then
            m = m + 1
            brr(m, 1) = t(i)
        End If
    Next
    [b3:b1000].ClearContents
    [b3].Resize(UBound(brr)) = brr
End Sub

yayahzmeng

你的标题果然成功了

jiminyanyan

http://club.excelhome.net/forum. ... ead&tid=1334957
一帖多发的同学，我要加入黑名单了。