VBA自动查找相同条件的行

dst1213

如附件， 模板.rar (14.86 KB, 下载次数: 28)

2014-10-20 13:20 上传

点击文件名下载附件

如何在sheet2中找到符合sheet1所列ID的stack run ID，并全部查找所有相同的stack run ID的各行，同时复制到sheet3中。
附件的代码总是出现很多重复的ID，不知道怎么办。
求解决！

doitbest

“并全部查找所有相同的stack run ID的各行”
这句何意，没说清楚

dst1213

doitbest 发表于 2014-10-20 16:49
“并全部查找所有相同的stack run ID的各行”
这句何意，没说清楚

在sheet2中查找sheet1中ID对应的stack run ID，并把sheet2列中相应的stack run ID，相同的行都复制到sheet3，如sheet2的黄色所示

doitbest

看是否是你想要的结果，不行就要演示一个结果了
Public Sub abc()
Dim ar, I, str, rng As Range
ar = Sheet1.Range("a1").CurrentRegion
For I = 2 To UBound(ar)
    str = str & " " & Sheet2.[a:a].Find(ar(I, 1)).Offset(, 2)
Next
ar = Sheet2.Range("a1").CurrentRegion
For I = 2 To UBound(ar)
    If InStr(str, ar(I, 3)) > 0 Then
        If rng Is Nothing Then Set rng = Sheet2.Rows(I) Else Set rng = Union(rng, Sheet2.Rows(I))
    End If
Next
rng.Copy Sheet3.[a1]
End Sub

dst1213

doitbest 发表于 2014-10-20 21:02
看是否是你想要的结果，不行就要演示一个结果了
Public Sub abc()
Dim ar, I, str, rng As Range

谢谢，我试试

dst1213

dst1213 发表于 2014-10-21 08:23
谢谢，我试试

那代码不是我想要的，我说明了一下想要的，见附图 模板2.rar (46.28 KB, 下载次数: 8)

2014-10-21 13:11 上传

点击文件名下载附件

jasonchow

Sub test()
    Dim arr1, arr2, mRow1&, mRow2&
    arr1 = Sheets(1).Range("A1").CurrentRegion
    mRow1 = Sheets(1).[a65536].End(xlUp).Row
    arr2 = Sheets(2).Range("A1").CurrentRegion
    mRow2 = Sheets(2).[a65536].End(xlUp).Row
   
    l = 2
    For i = 2 To mRow1
        For j = 2 To mRow2
            If arr1(i, 1) = arr2(j, 1) Then
                For k = 2 To mRow2
                    If arr2(j, 3) = arr2(k, 3) Then
                        Sheets(2).Rows(k).Copy Sheets(3).Rows(l)
                        l = l + 1
                    End If
                Next
            End If
        Next
    Next
   
End Sub

dst1213

jasonchow 发表于 2014-10-21 14:12
Sub test()
    Dim arr1, arr2, mRow1&, mRow2&
    arr1 = Sheets(1).Range("A1").CurrentRegion

没有标题啊，能加个标题么？代码是正确的。谢谢！

jasonchow

dst1213 发表于 2014-10-21 18:26
没有标题啊，能加个标题么？代码是正确的。谢谢！

sheets(2).rows(1).copy sheets(3).rows(1)

在前面加一句就可以了

dst1213

jasonchow 发表于 2014-10-22 09:56
sheets(2).rows(1).copy sheets(3).rows(1)

在前面加一句就可以了

好的 谢谢！