从其他工作簿导入数据

Sub ImportDataTEST()
    ImportData "Book2", ThisWorkbook
End Sub

Sub ImportData( _
        ByVal SourceWorkbookName As String, _
        ByVal DestinationWorkbook As Workbook)
    
    Const SRC_CONTAINS_CRITERION As String = "15"
    Const SRC_FIRST_ROW_RANGE As String = "A39:H39"
    Const DST_FIRST_CELL As String = "A1"
    Dim Headers(): Headers _
        = VBA.Array("Reviewer", "Criterion", "Type", "Level", "Comment")

    Dim swb As Workbook
    On Error Resume Next
        Set swb = Workbooks(SourceWorkbookName)
    On Error GoTo 0
    If swb Is Nothing Then Exit Sub ' workbook not open (doesn't exist!?)
    
    Dim sws As Worksheet, srg As Range, slCell As Range, swsName As String
    Dim dws As Worksheet, dfCell As Range
           
    For Each sws In swb.Worksheets
        swsName = sws.Name
        If InStr(swsName, SRC_CONTAINS_CRITERION) > 0 Then
            With DestinationWorkbook
                Set dws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            End With
            With dws
                ' Suppress error if destination worksheet name is taken.
                On Error Resume Next
                    .Name = swsName
                On Error GoTo 0
                Set dfCell = .Range(DST_FIRST_CELL)
            End With
            With dfCell.Resize(, UBound(Headers) + 1)
                .Value = Headers
                .Font.Bold = True
            End With
            If sws.FilterMode Then sws.ShowAllData ' prevent 'Find' failure
            With sws.Range(SRC_FIRST_ROW_RANGE)
                Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
                    .Find("*", , xlFormulas, , xlByRows, xlPrevious)
                If Not slCell Is Nothing Then
                    Set srg = .Resize(slCell.Row - .Row + 1)
                End If
            End With
            If Not srg Is Nothing Then
                srg.Copy dfCell.Offset(1)
                Set srg = Nothing
            End If
        End If
    Next sws
    
End Sub