多个条件匹配/搜索vba

时间:2017-08-17 08:45:04

标签: vba match

美好的一天,

我一直在试图弄清楚如何在多个工作表上编写多标准搜索。

我有3个w在行a上有数据:日期,行b:字符串,行c:金额。我的目标是在列b和c上完全匹配的所有三个工作表中找到重复项。生成的匹配应复制到新创建的工作表上。

这是我到目前为止所尝试的:

Dim WS As Worksheet, WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim st_cell As Range, frow1 As Range, frow2 As Range, frow3 As Range, mydata As Range, cell As Range, Descr1 As Range, Descr2 As Range, Descr3 As Range
Dim p As Long

Set WS1 = ThisWorkbook.Sheets(2)
Set WS2 = ThisWorkbook.Sheets(3)
Set WS3 = ThisWorkbook.Sheets(4)

    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(ActiveSheet.Name).Name = "Report"
    Sheets("Report").Range("A1") = "Description"
    Sheets("Report").Range("B1") = "Amount"
    erow = Sheets("Report").Cells(1, 1).CurrentRegion.Rows.Count + 1



    Set st_cell = WS1.Cells(2, 2)
        lastrow = WS1.Cells(WS1.Rows.Count, st_cell.Column).End(xlUp).row


    Set frow1 = WS2.Cells(2, 2)
        lastrow1 = WS2.Cells(WS2.Rows.Count, frow1.Column).End(xlUp).row


    Set frow2 = WS3.Cells(2, 2)
        lastrow2 = WS3.Cells(WS3.Rows.Count, frow2.Column).End(xlUp).row


    With WS1
    For i = 2 To lastrow
        Set Descr1 = WS1.Range(Cells(i, 2), Cells(i, 3))


    For Each Descr1 In ThisWorkbook.Worksheets
                    If (Descr1 <> Empty) Then
    For p = 2 To lastrow1 And lastrow2
        Set Descr2 = WS2.Range(Cells(p, 2), Cells(p, 3))
        Set Descr3 = WS3.Range(Cells(p, 2), Cells(p, 3))

                    Set mydata = WS1.Range(Cells(i, 2), Cells(i, 3)).Find(what:=Descr1, after:=.Cells(i, 2), LookIn:=xlValues, lookat:=xlWhole)
                If Not mydata Is Nothing Then
                    Sheets("Report").Cells(erow, 1) = WS1.Cells(i, "b")
                    Sheets("Report").Cells(erow, 2) = WS1.Cells(i, "c")
                    Exit Sub
                End If
    Next p
    End If
    Next Descr1


Next i
End With

End Sub

运行时我收到错误:工作表超出范围。请帮忙。

提前致谢。

1 个答案:

答案 0 :(得分:0)

如果您只有3张纸,则行Set WS3 = ThisWorkbook.Sheets(4)错误,因为您引用了第四张纸。如果您想要第四张工作表,则应使用Worksheets.Add方法。要清楚了解如何根据需要使用该功能,请参阅此Microsoft site