在多个工作薄中删除与源数据中相同身份证号的人员

HooPHooP

在平江组、工字 组、花果组三个工作薄中删除与源数据工作薄中相同身份证号的人员，并返回下列统计数据

半百

沈默00

沈默00

试一下....

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.7
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     arr = sh.UsedRange
   
7.     For i = 1 To UBound(arr)
   
8.         s = CStr(arr(i, 2))
   
9.         d(s) = ""
   
10.     Next
    
11.     ReDim zrr(1 To 1000, 1 To 2)
    
12.     zrr(1, 1) = "组": zrr(1, 2) = "人数"
    
13.     n = 1
    
14.     p = ThisWorkbook.Path & ""
    
15.     For Each f In fso.GetFolder(p).Files
    
16.         If f.Name Like "*.xls*" Then
    
17.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
18.                 fn = fso.GetBaseName(f)
    
19.                 m = 0: n = n + 1
    
20.                 zrr(n, 1) = fn
    
21.                 Set wb = Workbooks.Open(f, 0)
    
22.                 With wb.Sheets(1)
    
23.                     arr = .UsedRange
    
24.                     ReDim brr(1 To UBound(arr), 1 To 2)
    
25.                     For i = 1 To UBound(arr)
    
26.                         s = CStr(arr(i, 2))
    
27.                         t = d(s)
    
28.                         If t = Empty Then
    
29.                             m = m + 1
    
30.                             brr(m, 1) = arr(i, 1)
    
31.                             brr(m, 2) = s
    
32.                         End If
    
33.                     Next
    
34.                     .UsedRange = ""
    
35.                     .[a1].Resize(m, 2) = brr
    
36.                     zrr(n, 2) = m
    
37.                 End With
    
38.                 wb.Close 1
    
39.             End If
    
40.         End If
    
41.     Next f
    
42.     With sh
    
43.         .[g:h].Clear
    
44.         .[g1].Resize(n, 2) = zrr
    
45.         .[g1].Resize(n, 2).Borders.LineStyle = 1
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

LIUZHU

JSA代码尝试下，结果不知道对不对

1. function 数据统计(){
   
2.         let sfarr=Sheets.Item("Sheet1").Range("a1").CurrentRegion.Value2.map(x=>x[1]);
   
3.         let fname=Dir(`${ThisWorkbook.Path}\\*.xlsx`,8),obj={"组":"人数"};
   
4.         while(fname!=""){
   
5.                 Workbooks.Open(`${ThisWorkbook.Path}\\${fname}`,8);
   
6.                 obj[fname.slice(0,-5)]=ActiveSheet.UsedRange.Value2.reduce((sum,[a,b])=>sum+=!sfarr.includes(b),0);
   
7.                 ActiveWorkbook.Close(false);
   
8.                 fname=Dir();
   
9.         }
   
10.         let res=Object.entries(obj);
    
11.         (Sheets.Item("统计结果").Activate(),ActiveSheet).Range("a1").Resize(res.length,res[0].length).Value2=res;
    
12. }

复制代码

LIUZHU

附件在此，请用WPS测试

gwjkkkkk

字典与数组。。。

limonet

关键字：update+where