ExcelVBA从工作簿中查询多个姓名并复制出整行数据

Sub ExcelVBA从工作簿中查询多个姓名并复制出整行数据()

    Dim outFile As String, inFile As String

    Dim outWb As Workbook, mysht As Worksheet, tempsht As Worksheet, t_arr(1 To 30)

    Dim SearchRange As Range

    Dim LastRow As Integer, arr, FindStr As String, inWbSheet As String

    With Worksheets("设置")

        outFile = .Range("B1").Value

        LastRow = .Range("A200000").End(xlUp).Row

        If Dir(outFile, 16) = Empty Or LastRow < 3 Then MsgBox ("初始数据不完整"): Exit Sub

        arr = .Range("A3:A" & LastRow).Value

        Debug.Print UBound(arr)

    End With

    Set mysht = Worksheets("结果")

    Set tempsht = Worksheets("过程")

    mysht.Cells.Clear

    tempsht.Cells.Clear

    disAppSet (False)

    t = Timer()

    FindStr = ""

    Set outWb = Workbooks.Open(outFile)

    With outWb

        For i = 1 To UBound(arr)

            FindStr = arr(i, 1)

            For Each sht In .Sheets

                With sht

                    Set SearchRange = .Cells.Find(What:=FindStr, After:=.Range("A1"))

                    ' 如果已找到匹配项

                    If Not SearchRange Is Nothing Then

                        FirstAddress = SearchRange.Address

                        '                        Debug.Print FindStr & "-" & FirstAddress

                        Do                                     '找到了，要做什么========

                            OutShtName = sht.Name

                            LastRow = getLastRow(mysht, t_arr) + 1

                            SearchRange.EntireRow.Copy mysht.Range("A" & LastRow)

                            TempRow = getLastRow(tempsht, t_arr) + 1

                            tempsht.Range("A" & TempRow) = OutShtName

                            Set SearchRange = .Cells.FindNext(SearchRange)

                            ' 当不再找得到匹配项时, 退出过程

                            If SearchRange Is Nothing Then

                                Exit Sub

                            End If

                            ' 在找到唯一匹配项时继续查找

                        Loop While SearchRange.Address <> FirstAddress

                    Else

                        ' 则没有找到匹配的 MsgBox ("一个也没找到")

                    End If

                    '==end=工作表内部

                End With

                '''=end= for each sht in .Sheets

            Next

            '''==arr=行

            FindStr = ""

        Next i

        .Close False

        '===end= outWb

    End With

    tempsht.Columns("A:A").Copy

    With Sheets("结果")

        .Select

        .Columns("A:A").Select

        Selection.Insert Shift:=xlToRight

        .UsedRange.Columns.AutoFit

    End With

    tempsht.Cells.Clear

    Set outWb = Nothing

    disAppSet (True)

    MsgBox ("完成,用时：" & Format(Timer - t, "00.00秒"))

End Sub

    ''''用法：disAppSet(true)开disAppSet(true)关

Sub disAppSet(flag As Boolean)

    With Application

        .ScreenUpdating = flag

        .DisplayAlerts = flag

        .AskToUpdateLinks = flag

        If flag Then

            .Calculation = xlCalculationAutomatic

        Else

            .Calculation = xlCalculationManual

        End If

    End With

End Sub

    ''''判断工作表是否存在,本次没用到此函数

Function MyExistSh(Sh As String) As Boolean

    Dim sht As Object

    On Error Resume Next

    Set sht = Sheets(Sh)

    If Err.Number = 0 Then MyExistSh = True

    Set sht = Nothing

End Function



    '# #   输入工作表，空一维数组arr(1 to x)，返回最大行数

Function getLastRow(sht, arr)

    Dim ti As Integer

    With sht

        For ti = LBound(arr) To UBound(arr)

            If ti <= 0 Then Exit For

            arr(ti) = .Cells(Rows.Count, ti).End(xlUp).Row

        Next ti

    End With

    getLastRow = Application.WorksheetFunction.Max(arr)

End Function