请高手师傅们帮忙看下这个清除指定数据的难题

qiongmei6

我希望在附件内求得一个代码，就是在汇总表格中如果d列的身份证号一样，k列没有“工”的g：j列的数据都变成0.00，有“工”则保留不变，例如表格中有两行都是12345的身份证号，其中没有工的第6行的g：j列都变成0.00，目前的汇总表格中的g：j就是我希望用代码执行后的结果，谢谢各位大神的帮忙

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With [A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            dic(ar(i, 4)) = dic(ar(i, 4)) & " " & i
        Next i
        For Each vKey In dic.keys
            br = Split(dic(vKey))
            If UBound(br) > 1 Then
                For i = 1 To UBound(br)
                    If ar(br(i), UBound(ar, 2)) <> "工" Then
                        For j = 7 To UBound(ar, 2) - 1
                            .Cells(br(i), j) = 0
                        Next j
                    End If
                Next i
            End If
        Next
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

............

ykcbf1100

附件供参考

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.17
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("汇总")
   
4.         r = .Cells(Rows.Count, 4).End(3).Row
   
5.         For i = 2 To r
   
6.             s = .Cells(i, 4).Value
   
7.             d(s) = d(s) + 1
   
8.         Next
   
9.         For i = 2 To r
   
10.             s = .Cells(i, 4).Value
    
11.             If d(s) > 1 And InStr(.Cells(i, "k").Value, "工") = 0 Then
    
12.                 For j = 7 To 10
    
13.                     .Cells(i, j).Value = 0
    
14.                 Next
    
15.             End If
    
16.         Next
    
17.     End With
    
18.     Set d = Nothing
    
19.     MsgBox "OK！"
    
20. End Sub
    
21. 
    

复制代码

lsc900707

只要在上一代吗中加个判断就可以！