ExcelVBA条件查找多文件并由整行复制到模板再存为新工作簿

Sub yhd查询多文件输入模板生成新文件()
    Dim arr
    Dim wb As Object
    With Worksheets("设置")
        endrow = .Range("D10000").End(xlUp).Row
        If endrow <= 3 Then MsgBox "还有设置初值": Exit Sub
        Call CheckBlank(.Range("D4:H" & endrow))
        '取得要查找的数据源数据
        arr = .Range("D4:H" & endrow)
        '取得姓名与身份证（条件数组brr）
        brr = .Range("A4:B" & .Range("A10000").End(xlUp).Row)
    End With
    t = Timer
    Call disAppSet(False)
    Set thisWb = ThisWorkbook
    For a = 1 To UBound(brr)
    '循环条件数组brr
        wsh_num = Worksheets.Count
        Worksheets("模板").Copy After:=Worksheets(wsh_num)
        '复制“模板”文件为新的工作表，等待输入数据
        For i = 1 To UBound(arr)
            '打开文件，i行1列=文件路径
            Set wb = GetObject(arr(i, 1))
            '进入打开文件的工作表，i行2列=工作表名,
            With wb.Worksheets(arr(i, 2))
                endrow = .Cells.Find("*", , , , 1, 2).Row
                For j = 1 To endrow
                    '                Debug.Print .Cells(j, arr(i, 3)), UCase(.Cells(j, arr(i, 4)))
                    If .Cells(j, arr(i, 3)) = brr(a, 1) And UCase(.Cells(j, arr(i, 4))) = UCase(brr(a, 2)) Then
                        '如果3=姓名=姓名 and 4=大写身份证=大写身份证，则复制整行数据
                        .Range("A" & j).EntireRow.Copy thisWb.Worksheets(wsh_num + 1).Cells(arr(i, 5), 1)
                        outtext = outtext & arr(i, 1) & "-找到数据" & Chr(10)
                        Exit For
                    Else
                        '== MsgBox arr(i, 1) & Chr(10) & "中没找到数据"
                    End If
                Next j
            End With
            wb.Close False
        Next i
        Application.Calculation = xlCalculationAutomatic
        With Worksheets(wsh_num + 1)
            .Range("B5:D5").Copy .Range("B19:D19")
            .Range("B1") = brr(a, 1) & .Range("B1")
            saveName = brr(a, 1) & .Range("H19")
            .Move
        End With
        '移动复制出来的工作表，另存为新的工作簿
        '    Worksheets(wsh_num + 1).Move
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & saveName & ".xlsx"
        ActiveWorkbook.Worksheets(1).Name = "模板"
        ActiveWorkbook.Close SaveChanges:=True
    Next a
    thisWb.Worksheets("设置").Activate
    Call disAppSet(True)
    MsgBox "用时：" & Timer - t & Chr(10) & outtext
End Sub
 '========CheckBlank检测空值，如果有空就退出=========
    '使用方法
    '    Dim r As Range
    '    Set r = Union(Range("M4:O4"), Range("M8:O8"))
    '    Call CheckBlank(r)
    '=================
Sub CheckBlank(rng)
    For Each r In rng
        If Application.WorksheetFunction.CountBlank(r) Then
            MsgBox "你在" & r.Address & "没有填写内容"
            Exit Sub
        End If
    Next
End Sub
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

Sub SelectFile()
    '选择单一文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        '单选择
        .Filters.Clear
        '清除文件过滤器
        .Filters.Add "Excel Files", "*.xls*;*.xlw"
        .Filters.Add "All Files", "*.*"
        '设置两个文件过滤器
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
            'MsgBox "您选择的文件是：" & .SelectedItems(1), vbOKOnly + vbInformation, "提示"
            filepath = .SelectedItems(1)
            With Worksheets("设置")
                .Range("D" & .Range("D10000").End(xlUp).Row + 1) = filepath
            End With
        End If
    End With
End Sub