急求一薄内多个工作表中保留指定内容的行

思水年华

    工作薄内有100个工作表。A列序号和B列机构有我需要的，我要把不需要的内容的行删掉，只保留所需要机构的行就可以了。（A列序号和B列机构是相对的，好比序号300是机构C  在其它的100个工作表中，序号300都是机构C）  （序号不是量重要的，最重要是机构名称的行，把不要的机构删了）




工作表中保留需要的行内容.rar (11.94 KB, 下载次数: 12)

2023-3-19 11:06 上传

点击文件名下载附件

zjzyj

附件供参考      

全党

1. Sub shishi()
   
2. Dim brr(), Rng As Worksheet
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Set dic = CreateObject("Scripting.Dictionary")
   
6. arr = Range("a1").CurrentRegion
   
7. For i = 4 To UBound(arr)
   
8. If Not dic.exists(arr(i, 2)) Then
   
9. dic(arr(i, 2)) = ""
   
10. End If
    
11. Next
    
12. For Each Rng In Worksheets
    
13. If Rng.Name <> "说明" Then
    
14.     arr = Rng.Range("a1").CurrentRegion
    
15.     For i = 2 To UBound(arr)
    
16.     If dic.exists(arr(i, 2)) Then
    
17.     n = n + 1
    
18.     ReDim Preserve brr(1 To n)
    
19.     brr(n) = Array(n, arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
20.     End If
    
21.     Next
    
22.     Rng.Range("a2:j500").Clear
    
23.     Rng.Range("a2").Resize(n, 10) = Application.Rept(brr, 1)
    
24.     n = 0
    
25.     Erase brr
    
26. End If
    
27. 
    
28. Next
    
29. Application.DisplayAlerts = True
    
30. Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

全党

参考一下，数组加字典

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, i&, j&, r&, wks As Worksheet, strJoin$
   
    Application.ScreenUpdating = False
    strJoin = "," & Join(Application.Transpose(Range("B4", Cells(Rows.Count, "B").End(3))), ",") & ","
   
    For Each wks In Sheets
        If wks.Name <> "说明" Then
            With wks
                With .[A1].CurrentRegion
                    ar = .Value
                    .Offset(1).Clear
                    r = 1
                End With
                For i = 2 To UBound(ar)
                    If InStr(strJoin, "," & ar(i, 2) & ",") Then
                        r = r + 1
                        For j = 1 To UBound(ar, 2)
                            ar(r, j) = ar(i, j)
                        Next j
                    End If
                Next i
                .[A1].Resize(r, UBound(ar, 2)) = ar
            End With
         End If
    Next wks
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

lizhipei78

用正则较快，且只需要改里面一个代码，即可实现是删除还是保留关键词所在行
经测试你给的表格0.5秒就可以了

lizhipei78

请参考，测试

1. Sub 正则提取保留关键词删除其它行()
   
2.     Dim Arr, Brr, Crr, i&, j&, t#, Str As String, endRow%, R%
   
3.     Dim sht As Worksheet
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     t = Timer
   
7.     Arr = Sheets("说明").Range("A1").CurrentRegion
   
8.     Str = Arr(4, 2)
   
9.     For i = 5 To UBound(Arr)
   
10.         Str = Str & "|" & Arr(i, 2)
    
11.     Next
    
12.     Str = "(" & Str & ")"
    
13.     For Each sht In Sheets
    
14.         With CreateObject("Vbscript.RegExp")
    
15.             .Pattern = Str
    
16.             If sht.Name = "说明" Then GoTo 100
    
17.             sht.Activate
    
18.             endRow = sht.Cells(Rows.Count, "B").End(xlUp).Row
    
19.             sht.AutoFilterMode = False
    
20.             Arr = sht.Range("B1").CurrentRegion
    
21.             ReDim Brr(1 To UBound(Arr), 1 To 1)
    
22.             For i = 2 To UBound(Arr)
    
23.                 If .test(Arr(i, 2)) = False Then '只需要更改这里true或者false就好了,true是保留,false是删除
    
24.                     R = R + 1
    
25.                     Brr(R, 1) = Arr(i, 2)
    
26.                 End If
    
27.             Next i
    
28.         End With
    
29.         Crr = Application.WorksheetFunction.Transpose(Brr)
    
30.         Range("B1").AutoFilter Field:=2, Criteria1:=Crr, Operator:=7
    
31.         Range("B2:B" & endRow).Delete
    
32.         Rows("1:1").AutoFilter
    
33.         R = 0
    
34. 100
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37.     Application.DisplayAlerts = True
    
38.     Sheets("说明").Activate
    
39.     MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
    
40. End Sub

复制代码

cjc209

lizhipei78 发表于 2023-3-20 11:33
用正则较快，且只需要改里面一个代码，即可实现是删除还是保留关键词所在行
经测试你给的表格0.5秒就 ...

5楼的方法最好

lizhipei78

cjc209 发表于 2023-3-20 11:45
5楼的方法最好

嗯，是好办法，但是我觉得如果列的数量多的话，我这个也不错，因为我只循环行，不对列进行操作，其实筛选删除并不比数组慢，特别是大数据的时候