VBA删除指定明细

阿哩木

又来再次求助！！请大佬帮帮忙，感谢感谢！！

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test() '2024-10-13
    Dim rng As Range
    With Sheet1
        r = .Cells(Rows.Count, 1).End(3).Row
        arr = .Range("a1:n" & r)
        brr = [q2:w2]
        Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(brr, 2)
            s = brr(1, i)
            If Not d.exists(s) And s <> Empty Then
                n = n + 1
                d(s) = n
            End If
        Next
        For i = r To 3 Step -1
            s = arr(i, 2)
            If d.exists(s) Then
                If rng Is Nothing Then
                    Set rng = .Cells(i, 1).Resize(, UBound(arr, 2))
                Else
                    Set rng = Union(rng, .Cells(i, 1).Resize(, UBound(arr, 2)))
                End If
            End If
        Next
    End With
    rng.Delete
    Beep
    Set d = Nothing
End Sub

Qs18

1. Sub qs()
   
2. Dim arr, i, brr
   
3. With Sheet1
   
4. arr = .Range("a3:n" & .Cells(Rows.Count, 1).End(3).Row)
   
5. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. brr = .[q2:w2]
   
7. For j = 1 To UBound(brr, 2)
   
8.     If brr(1, j) <> "" Then
   
9.     s = s & "|" & brr(1, j)
   
10.     End If
    
11. Next
    
12. For i = 3 To UBound(arr)
    
13.     If InStr(s, arr(i, 2)) = 0 Then
    
14.         m = m + 1
    
15.         For c = 1 To UBound(arr, 2)
    
16.             crr(m, c) = arr(i, c)
    
17.         Next
    
18.     End If
    
19. Next
    
20. .Range("a3:n1000") = ""
    
21. .Range("a3").Resize(m, UBound(arr, 2)) = crr
    
22. End With
    
23. End Sub
    

复制代码

Qs18

试试....................

Qs18

试试.......

ykcbf1100

和昨天的求助内容没啥区别啊。

ykcbf1100

再回复一次吧。

阿哩木

Qs18 发表于 2024-10-13 15:31
试试.......

您好，非常感谢您的帮忙。在Q2:W2的区域只输入张  代码运行后的结果有点不准确，麻烦您可以再帮忙看下吗，谢谢！！

阿哩木

quqiyuan 发表于 2024-10-13 15:20
参与一下，仅供参考。。。

谢谢大佬