查询指定序号相同数据（3月2日晚11点多已兑现50元红包）

谢金花

附件 指定位置查询A.rar (355.49 KB, 下载次数: 124)

2020-3-2 20:06 上传

点击文件名下载附件

谢谢各位老师！

谢金花

B1B2输入                964
                965

应在A4A5输入964 965

谢金花

有几个要求加QQ，本人没有QQ，只有微信。悬赏贴这是第二次了，只要我发给你原文件，在合适时间内报出结果，视为合格，马上兑现。

jsqb

有人抢红包？

micch

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Set fo = CreateObject("scripting.filesystemobject")
   
4.     Set fd = fo.getfolder(ThisWorkbook.Path)
   
5.     x = Sheet1.[a1]
   
6.     y = Sheet1.[a5]
   
7.     n = 1
   
8.     ReDim arr(1 To 7, 1 To 1)
   
9.     For Each f In fd.Files
   
10.         If Val(f.Name) Then
    
11.             fn = Split(f.Name, ".")(0)
    
12.                 Set w = Workbooks.Open(f)
    
13.                 With Sheets(1)
    
14.                         c = .Cells(x, 52).End(1).Column
    
15.                         brr = .Range("a" & x, .Cells(y, c))
    
16.                         For i = 1 To c
    
17.                                 If brr(1, i) = brr(UBound(brr) - 1, i) And brr(2, i) = brr(UBound(brr), i) Then
    
18.                                         arr(1, n) = brr(1, i)
    
19.                                         arr(2, n) = brr(2, i)
    
20.                                         arr(4, n) = brr(1, i)
    
21.                                         arr(5, n) = brr(2, i)
    
22.                                         arr(6, n) = fn
    
23.                                         arr(7, n) = Replace(.Cells(1, i).Address(0, 0), 1, "")
    
24.                                         n = n + 1
    
25.                                         ReDim Preserve arr(1 To 7, 1 To n)
    
26.                                 End If
    
27.                         Next i
    
28.                 End With
    
29.                 w.Close False
    
30.         End If
    
31.     Next
    
32.     Sheet1.[b1].Resize(7, n) = arr
    
33.     Application.ScreenUpdating = True
    
34. End Sub

复制代码