从关闭的工作簿导入数据

假设

• 在工作表Data的5行开始的A列中有一个源库名称（不带扩展名的文件名）列表。
• 在Resultados页的B1:ZZ1中可以找到相同的名称。
• 您希望在与包含此代码和包含前面提到的工作表的工作簿的路径相同的路径中打开文件。
• 当你打开一个文件时，你想从工作表的单列范围B42:B53复制值，我选择了Sheet1（调整它！），到工作表Resultados的正确标题下。

Option Explicit

Sub ImportData()
    
    ' Define constants.
    
    Const DST_NAMES_SHEET As String = "Data"
    Const DST_NAMES_FIRST_CELL As String = "A5"
    Const DST_RESULTS_SHEET As String = "Resultados"
    Const DST_HEADERS_RANGE As String = "B1:ZZ1"
    
    Const SRC_SHEET As String = "Sheet1" ' ADJUST!!!
    Const SRC_RANGE As String = "B42:B53"
    Const SRC_FILE_EXTENSION As String = ".xlsm"
    
    ' Destination
    
    ' I'm assuming that the following are all the same workbook:
    ' Maestro, Windows("ARCHIVO MAESTRO.xlsm"), ThisWorkbook, ActiveWorkbook
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    Dim dnws As Worksheet: Set dnws = dwb.Sheets(DST_NAMES_SHEET)
    Dim dfCell As Range: Set dfCell = dnws.Range(DST_NAMES_FIRST_CELL)
    Dim dlCell As Range:
    Set dlCell = dnws.Cells(dnws.Rows.Count, dfCell.Column).End(xlUp)
    Dim dnrg As Range: Set dnrg = dnws.Range(dfCell, dlCell)
    
    Dim dws As Worksheet: Set dws = dwb.Sheets(DST_RESULTS_SHEET)
    Dim drg As Range: Set drg = dws.Range(DST_HEADERS_RANGE)
    Dim rCount As Long: rCount = dws.Range(SRC_RANGE).Rows.Count
    
    ' Source
    
    Dim sPath As String: sPath = dwb.Path & Application.PathSeparator

    ' Open each file and copy the range.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, dnCell As Range, dcIndex
    Dim sFilePath As String, sBaseName As String
    
    For Each dnCell In dnrg.Cells
        sBaseName = CStr(dnCell.Value)
        sFilePath = sPath & sBaseName & SRC_FILE_EXTENSION
        On Error Resume Next ' prevent error if workbook doesn't exist
            Set swb = Workbooks.Open(sFilePath)
        On Error GoTo 0
        If swb Is Nothing Then ' source file not found; workbook not opened
            MsgBox "File """ & sFilePath & """ not found.", vbCritical
        Else ' source file found; workbook opened
            On Error Resume Next ' prevent error if worksheet doesn't exist
                Set sws = swb.Worksheets(SRC_SHEET)
            On Error GoTo 0
            If sws Is Nothing Then ' source worksheet not found
                MsgBox "Worksheet """ & SRC_SHEET & """ not found.", vbCritical
            Else ' source worksheet found
                Set srg = sws.Range(SRC_RANGE)
                dcIndex = Application.Match(sBaseName, drg, 0)
                If IsNumeric(dcIndex) Then ' source base name found
                    drg.Cells(dcIndex).Offset(1) _
                        .Resize(rCount).Value = srg.Value
                'Else ' source base name not found among the headers
                End If
                Set sws = Nothing ' reset for the next iteration
            End If
            swb.Close SaveChanges:=False
            Set swb = Nothing ' reset for the next iteration
        End If
    Next dnCell
    
    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Data imported.", vbInformation
    
End Sub