提取符合条件行数据的问题

dfshm

附件 提取符合条件行数据附件.rar (791.25 KB, 下载次数: 9)

2023-3-29 16:19 上传

点击文件名下载附件

谢谢老师！

杨建营

请楼主参考。

gwjkkkkk

Option Explicit
Sub test()
    Dim f, p$, ar, vResult, i&, r&, strJoin$
   
    Application.ScreenUpdating = False
    strJoin = [A1] & "|" & [B1]
    ReDim vResult(1 To 10 ^ 6, 1 To 4)
    p = ThisWorkbook.Path & "\"
   
    For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(p).Files
        If f.Name Like "*.xlsb" Then
            With GetObject(f)
                ar = .ActiveSheet.[A1].CurrentRegion
                For i = 1 To UBound(ar)
                    If ar(i, 1) & "|" & ar(i, 2) = strJoin Then
                        r = r + 1
                        vResult(r, 1) = ar(i, 1)
                        vResult(r, 2) = ar(i, 2)
                        vResult(r, 3) = i
                        vResult(r, 4) = Left(.Name, InStrRev(.Name, ".") - 1)
                    End If
                Next i
                .Close False
            End With
        End If
    Next
   
    [E1].CurrentRegion.Clear
    [E1].Resize(r, 4) = vResult
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。