请问，如何按关键字查找另一表并把查到的行复制到新的表格中？

mjf21cn

"表一"有I列表头为“关键字1”，
在"凭证表2020"H列查找“关键字1”，如果H列包含“关键字1”的字符、并且L列“借方发生额”等于"表一"的G列“金额”、或者M列“贷方发生额”等于"表一"的G列“金额”,则取得"凭证表2020"当前行的凭证编号（E列），并把"表一"的当前行复制到"对比表"中，把"凭证表2020"中E列"凭证编号"等于刚取得的凭证号的所有行复制到刚复制过来的右侧，效果如“对比表2020”。
我自己写了一个vba代码，但运行不了，请问怎么解决？详见附件，谢谢：
Sub 对比2020()
Dim a As String
m = 2
n = 2
p = 2
Sheets("表一").Select
Do While Not (IsEmpty(Sheets("表一").Cells(m, 1).Value))
a = Sheets("表一").Cells(m, 9)
Sheets("凭证表2020").Select
Do While Not (IsEmpty(Sheets("凭证表2020").Cells(m, 1).Value))
If Sheets("凭证表2020").Cells(n, 8) Like a = True And (Sheets("表一").Cells(m, 7) = Sheets("凭证表2020").Cells(n, 8) Or Sheets("表一").Cells(m, 7) = Sheets("凭证表2020").Cells(n, 9)) Then
Sheets("表一").Select
Range("a&m:i&m").Select
Selection.Copy
Sheets("对比表2020").Select
Range("a" & p).Select
ActiveSheet.Paste
Sheets("凭证表2020").Select
Range("A&n:M&n").Select
Selection.Copy
Sheets("对比表2020").Select
Range("J" & p).Select
ActiveSheet.Paste
Else
  n = n + 1
End If
Loop
m = m + 1p = p + 1
Loop
End Sub

hasyh2008

试试看！！！！

roserice

=FILTER(凭证表2020!A2:M6,IFERROR(SEARCH("旱河临时污水",凭证表2020!H2:H6),0)*IFERROR(SEARCH(表一!G2,凭证表2020!L2:L6),0))

我行我速2008

Sub 对比()
    Application.ScreenUpdating = False
    Dim Ar, Br, Cr, R%, C%, X%, Y%, K%, I%, Sr1$, Sr2$, Sr3$
    ClearContents
    Ar = Sheets("表一").Range("A1").CurrentRegion
    Br = Sheets("凭证表2020").Range("A1").CurrentRegion
    For R = 2 To UBound(Ar)
        Sr1 = Ar(R, 9)
        K = 0
        ReDim Cr(1 To UBound(Br, 2), 1 To 1)
        For X = 2 To UBound(Br)
            Sr2 = Br(X, 8): Sr3 = Br(X, 5)
            If InStr(Sr2, Sr1) > 0 And Ar(R, 7) = Br(X, 12) Then
                For I = 2 To UBound(Br)
                    If Br(I, 5) = Sr3 Then
                        K = K + 1
                        ReDim Preserve Cr(1 To UBound(Br, 2), 1 To K)
                        For Y = 1 To UBound(Br, 2)
                            Cr(Y, K) = Br(I, Y)
                        Next Y
                    End If
                Next I
                Sheets("表一").Cells(R, 1).Resize(1, 9).Copy Sheets("对比表2020").Range("A" & Sheets("对比表2020").Cells(Rows.Count, 10).End(xlUp).Row + 1)
                Sheets("对比表2020").Range("J" & Sheets("对比表2020").Cells(Rows.Count, 10).End(xlUp).Row).Offset(1, 0).Resize(K, UBound(Br, 2)) = Application.Transpose(Cr)
                GoTo 100
            ElseIf InStr(Sr2, Sr1) > 0 And Ar(R, 7) = Br(X, 13) Then
                For I = 2 To UBound(Br)
                    If Br(I, 5) = Sr3 Then
                        K = K + 1
                        ReDim Preserve Cr(1 To UBound(Br, 2), 1 To K)
                        For Y = 1 To UBound(Br, 2)
                            Cr(Y, K) = Br(X, Y)
                        Next Y
                    End If
                Next I
                Sheets("表一").Cells(R, 1).Resize(1, 9).Copy Sheets("对比表2020").Range("A" & Sheets("对比表2020").Cells(Rows.Count, 10).End(xlUp).Row + 1)
                Sheets("对比表2020").Range("J" & Sheets("对比表2020").Cells(Rows.Count, 10).End(xlUp).Row).Offset(1, 0).Resize(K, UBound(Br, 2)) = Application.Transpose(Cr)
            End If
        Next X
100:
    Next R
    Application.ScreenUpdating = True
End Sub
Sub ClearContents()
    Sheets("对比表2020").Range("A1").CurrentRegion.Offset(1).ClearContents
End Sub

mjf21cn

hasyh2008 发表于 2022-7-25 09:47
试试看！！！！

可以用，非常感谢！

mjf21cn

我行我速2008 发表于 2022-7-25 17:16
Sub 对比()
    Application.ScreenUpdating = False
    Dim Ar, Br, Cr, R%, C%, X%, Y%, K%, I%, Sr1$ ...

非常感谢！

mjf21cn

roserice 发表于 2022-7-25 16:18
=FILTER(凭证表2020!A2:M6,IFERROR(SEARCH("旱河临时污水",凭证表2020!H2:H6),0)*IFERROR(SEARCH(表一!G2, ...

这个是怎么用的？

roserice

mjf21cn 发表于 2022-7-26 23:35
这个是怎么用的？

用两个search搜索出含有"临时旱河"
和对应金额的数据，在用filter进一步搜索出具体数据