按姓名保留行

eikok

按姓名保留行.7z (25.97 KB, 下载次数: 10)

2024-8-27 09:28 上传

点击文件名下载附件

Sub TEST()
    For I = Range("B65536").End(3).Row To 2 Step -1
        If InStr("张三1", Cells(I, "A").Value) Then
            GoTo 10
        Else
            Rows(I).Delete
        End If
10  Next
End Sub


（以前的代码，大神帮改一下，以适用附件的excel）

eikok

Sub KeepRowsWithMultipleNames()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 使用当前活跃的工作表
   
    Dim namesArray As Variant
    namesArray = Array("张三1", "李四2", "王五3") ' 定义需要保留的名字数组，根据需要添加或删除名字
   
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ' 找到B列最后一个非空单元格的行号
   
    Dim i As Long
    Dim name As Variant
    For i = lastRow To 4 Step -1 ' 从最后一行反向遍历到第4行
        For Each name In namesArray ' 遍历名字数组
            If InStr(1, ws.Cells(i, "B").Value, name, vbTextCompare) > 0 Then ' 检查B列是否包含数组中的任何一个名字
                Exit For ' 如果找到匹配的名字，则跳出内层循环，保留该行
            End If
        Next name
        
        If name <> namesArray(0) Then ' 如果内层循环结束时name未改变，说明没找到匹配项，可以删除该行
            ws.Rows(i).Delete
        End If
    Next i
End Sub

ykcbf1100

附件没见有代码。需求说明也不清楚。
先看一下再定。

longwin

Sub TEST()
    For I = Range("B65536").End(3).Row To 2 Step -1
        If InStr("张三1", Cells(I, "B").Value) = 0 Then     
            Rows(I).Delete
        End If
   Next
End Sub

taller

taller

1.     Dim ws As Worksheet
   
2.     Set ws = ActiveSheet ' 使用当前活跃的工作表
   
3.    
   
4.     Dim namesArray As Variant
   
5.     namesArray = Array("张三1", "李四2", "王五3") ' 定义需要保留的名字数组，根据需要添加或删除名字
   
6.    
   
7.     Dim lastRow As Long
   
8.     lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ' 找到B列最后一个非空单元格的行号
   
9.    
   
10.     Dim i As Long, rngDel As Range
    
11.     Dim name As Variant, bFound As Boolean
    
12.     For i = lastRow To 4 Step -1 ' 从最后一行反向遍历到第4行
    
13.         bFound = False
    
14.         For Each name In namesArray ' 遍历名字数组
    
15.             If InStr(1, ws.Cells(i, "B").Value, name, vbTextCompare) > 0 Then ' 检查B列是否包含数组中的任何一个名字
    
16.                 bFound = True ' 匹配成功
    
17.                 Exit For ' 如果找到匹配的名字，则跳出内层循环，保留该行
    
18.             End If
    
19.         Next name
    
20.         If Not bFound Then ' 如果内层循环结束时name未改变，说明没找到匹配项，可以删除该行
    
21.             ' 待删除行保存到rngDel
    
22.             If rngDel Is Nothing Then
    
23.                 Set rngDel = ws.Cells(i, "B")
    
24.             Else
    
25.                 Set rngDel = Application.Union(rngDel, ws.Cells(i, "B"))
    
26.             End If
    
27.         End If
    
28.     Next i
    
29.     ' 一次行删除多行，效率更高
    
30.     If Not rngDel Is Nothing Then
    
31.         rngDel.EntireRow.Delete
    
32.     End If
    
33. End Sub
    

复制代码