对应四个数提取整行数据的问题

杨小妹

附件 对应四个数提取整行数据.rar (548.3 KB, 下载次数: 17)

2024-3-11 14:23 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.3.11
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     With sh
   
8.         zrr = .[a1:e8]
   
9.         For i = 1 To UBound(zrr)
   
10.             s = zrr(i, 1) & "|" & zrr(i, 2) & "|" & zrr(i, 3) & "|" & zrr(i, 5)
    
11.             d(s) = ""
    
12.         Next
    
13.     End With
    
14.     ReDim brr(1 To 10000, 1 To 7)
    
15.     p = ThisWorkbook.Path & ""
    
16.     For Each f In Fso.GetFolder(p).Files
    
17.         If f.Name Like "*.xlsb" Then
    
18.             fn = Fso.GetBaseName(f)
    
19.             Set wb = Workbooks.Open(f, 0)
    
20.             With wb.Sheets("Sheet1")
    
21.                 r = .Cells(Rows.Count, 1).End(3).Row
    
22.                 arr = .[a1].Resize(r, 6)
    
23.                 wb.Close False
    
24.             End With
    
25.             For i = 1 To UBound(arr)
    
26.                 s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 5)
    
27.                 If d.exists(s) Then
    
28.                     m = m + 1
    
29.                     For j = 1 To UBound(arr, 2)
    
30.                         brr(m, j) = arr(i, j)
    
31.                     Next
    
32.                     brr(m, 7) = fn
    
33.                 End If
    
34.             Next
    
35.         End If
    
36.     Next f
    
37.     With sh
    
38.         .[a12].Resize(10000, 7) = ""
    
39.         .[a12].Resize(m, 7) = brr
    
40.     End With
    
41.     Set d = Nothing
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

清风竹-

请看附件。

蓝桥玄霜

调整的例子：

cnmlgb9998

PQ 完美！！！！！！！！！！！！！！！！！！