如何用VBA实现在多个sheet中进行模糊查询，并将包含关键字的一整行复制至指定位置？

Question

一个工作薄有sheet1，2，3，4，5，6.sheet5中有需要查询的关键字（很多，上千个），sheet5中的关键字一定可以在sheet1，2，3，4中找到且唯一。（sheet1，2，3，4，5中的关键字都在A列）。如果sheet5中关键字以05开头，则在sheet1中查询；如果sheet5中关键字以08开头，则在sheet2中进行查询；如果sheet5中关键字以1开头，则在sheet3中查询；否则，在sheet4中进行查询。并将在sheet1，2，3，4中查询到的包含sheet5中关键字的一整行复制至sheet6中。（包含关键字的sheet5中会有空行，如果sheet5中为空行，希望对应的shee6中仍然保留这个空行，即如果sheet5中A1有值，则sheet6中第一行为在sheet1，2，3，4中查询到的包含sheet5中A1关键字的一整行；如果sheet5中A1为空，则在sheet6中第一行就是一个空行）大致流程图如下：

还请高手指点，不胜感激~

Answer 1

Sub MySearch()

Dim ws(6) As Worksheet

Dim c1 As Range, c2 As Range

Dim r

    Set ws(1) = Worksheets("Sheet1")    ' 请自行修改为实际的工作表名

    Set ws(2) = Worksheets("Sheet2")    ' 请自行修改为实际的工作表名

    Set ws(3) = Worksheets("Sheet3")    ' 请自行修改为实际的工作表名

    Set ws(4) = Worksheets("Sheet4")    ' 请自行修改为实际的工作表名

    Set ws(5) = Worksheets("Sheet5")    ' 请自行修改为实际的工作表名

    Set ws(6) = Worksheets("Sheet6")    ' 请自行修改为实际的工作表名

    ws(6).Cells.Clear

   

    Set c2 = ws(6).Range("A1")

   

    For r = 1 To 1000   ' 由于未说明Sheet5中A列关键字的行数，且其中有空行，请自行修改为实际的行数

        Set c1 = ws(5).Range("A" & r)

        If c1 Like "1*" Then

            ws(3).Cells.Find(c1, lookat:=xlWhole).EntireRow.Copy Destination:=c2

        ElseIf c1 Like "05*" Then

            ws(1).Cells.Find(c1, lookat:=xlWhole).EntireRow.Copy Destination:=c2

        ElseIf c1 Like "0*" Then

            ws(2).Cells.Find(c1, lookat:=xlWhole).EntireRow.Copy Destination:=c2

        ElseIf c1 <> "" Then

            ws(4).Cells.Find(c1, lookat:=xlWhole).EntireRow.Copy Destination:=c2

        End If

        Set c2 = c2.Offset(1, 0)

    Next r

End Sub

本回答被提问者采纳