[已解决]请教老师，查找符合行：只要存在指定数中的一个或多个数

lygyjt

请教老师：        
        说明：“原始数据”表中，A列是序号，其它列是文本型数据。        
        在“查找”表的第1行，连续输入N个文本型数据。在原始数据表中，查找哪些行，有这N个数据中的1个或多个或全部。将这些行提取出来，去掉重复行，按序号升序的原则，放到“查找”表第2行开始的下面。
        见左侧的例子：不是答案，只是示意。

具体请见例子： 查找符合行：只要存在指定数中的一个或多个数.rar (30.69 KB, 下载次数: 20)

2022-11-9 15:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

benhsu

2022-11-9 15:58

Sub test01()
    Dim brr() As String
    count1 = Sheets("原始数据").[A1].End(xlDown).Row
    ReDim Preserve brr(1 To count1, 1 To 7)
    k = 1
    Sheets("查找").Range("A2:G" & Sheets("查找").[B1].End(xlDown).Row).Clear
    arr = Sheets("原始数据").Range("A1:g" & Sheets("原始数据").[A1].End(xlDown).Row)
    crr = Sheets("查找").Range("B1:E1")
    For i = 1 To UBound(arr)
        text1 = ""
        For j = 2 To UBound(arr, 2)
            text1 = text1 & "|" & arr(i, j)
        Next j
        For Z = 1 To UBound(crr, 2)
            If crr(1, Z) <> "" Then
                x = InStr(1, text1, crr(1, Z), vbTextCompare)
                If x > 0 Then
                    For x1 = 1 To 7
                        brr(k, x1) = arr(i, x1)
                    Next x1
                    k = k + 1
                    Exit For
                End If
            End If
        Next Z
    Next i
    Sheets("查找").Range("A2").Resize(count1, 7) = brr
    Erase arr
    Erase brr
    Erase crr
End Sub

跳转到最佳答案楼层

benhsu

Sub test01()
    Dim brr() As String
    count1 = Sheets("原始数据").[A1].End(xlDown).Row
    ReDim Preserve brr(1 To count1, 1 To 7)
    k = 1
    Sheets("查找").Range("A2:G" & Sheets("查找").[B1].End(xlDown).Row).Clear
    arr = Sheets("原始数据").Range("A1:g" & Sheets("原始数据").[A1].End(xlDown).Row)
    crr = Sheets("查找").Range("B1:E1")
    For i = 1 To UBound(arr)
        text1 = ""
        For j = 2 To UBound(arr, 2)
            text1 = text1 & "|" & arr(i, j)
        Next j
        For Z = 1 To UBound(crr, 2)
            If crr(1, Z) <> "" Then
                x = InStr(1, text1, crr(1, Z), vbTextCompare)
                If x > 0 Then
                    For x1 = 1 To 7
                        brr(k, x1) = arr(i, x1)
                    Next x1
                    k = k + 1
                    Exit For
                End If
            End If
        Next Z
    Next i
    Sheets("查找").Range("A2").Resize(count1, 7) = brr
    Erase arr
    Erase brr
    Erase crr
End Sub

benhsu

就是只要有出现过就复制行？

Sub test()
    Dim brr() As String
    count1 = Sheets("原始数据").[A1].End(xlDown).Row
    ReDim Preserve brr(1 To count1, 1 To 7)
    k = 1
    Sheets("查找").Range("A2:G" & Sheets("查找").[B1].End(xlDown).Row).Clear
    arr = Sheets("原始数据").Range("A1:g" & Sheets("原始数据").[A1].End(xlDown).Row)
    crr = Sheets("查找").Range("B1:E1")
    For i = 1 To UBound(arr)
        text1 = ""
        For j = 2 To UBound(arr, 2)
            text1 = text1 & "|" & arr(i, j)
        Next j
        For Z = 1 To UBound(crr, 2)
            x = InStr(1, text1, crr(1, Z), vbTextCompare)
            If x > 0 Then
                For x1 = 1 To 7
                    brr(k, x1) = arr(i, x1)
                Next x1
                k = k + 1
                Exit For
            End If
        Next Z
    Next i
    Sheets("查找").Range("A2").Resize(count1, 7) = brr
    Erase arr
    Erase brr
    Erase crr
End Sub

lygyjt

benhsu 发表于 2022-11-10 12:47
就是只要有出现过就复制行？

Sub test()

谢谢老师的指点！您说的对，有出现就提取此行。但最后需要删除重复行

benhsu

lygyjt 发表于 2022-11-10 18:28
谢谢老师的指点！您说的对，有出现就提取此行。但最后需要删除重复行

你所谓的重复行，是指原始数据500行中会有重复的？如果没有，上面的代码应该可以了

lygyjt

benhsu 发表于 2022-11-10 22:45
你所谓的重复行，是指原始数据500行中会有重复的？如果没有，上面的代码应该可以了

老师，我这边情况是这样：在第1行只输入010599（这个数原始数据中不存在）或01059，结果显示都是500行。在原始数据中，01059只存在96个。请老师如果有空，再改下行吗？

lygyjt

benhsu 发表于 2022-11-9 15:58
Sub test01()
    Dim brr() As String
    count1 = Sheets("原始数据").[A1].End(xlDown).Row

再次谢谢老师的辛苦！