Скопировать имена файлов в файл назначения

Копирование значений из закрытых файлов

Источники

Место назначения

Sub RetrieveData()
    
    Const PROC_TITLE As String = "Retrieve Data"
    
    ' Define constants.
    
    ' Source
    Const SRC_FOLDER_PATH As String = "C:\Test\"
    Const SRC_DIR_PATTERN As String = "*.csv"
    Const SRC_TOTALS_ROW_IDENTIFIER As String = "Total"
    Const SRC_TOTALS_ROW_OFFSET As Long = 1 ' 0 to copy totals row
    Const SRC_FIRST_ROW As Long = 10
    Const SRC_COLUMNS As String = "A:V"
    ' Destination
    Const DST_SHEET_NAME As String = "Consolidated Data"
    Const DST_FIRST_CELL_ADDRESS As String = "B2"
    Const DST_SOURCE_NAME_COLUMN As String = "A"
    
    Application.ScreenUpdating = False
    
    ' Reference the destination objects.
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Sheets(DST_SHEET_NAME)
    Dim dcell As Range: Set dcell = dws.Range(DST_FIRST_CELL_ADDRESS)
    Dim ColumnsCount As Long: ColumnsCount = dws _
        .Columns(SRC_COLUMNS).Columns.Count
    Dim drrg As Range: Set drrg = dcell.Resize(, ColumnsCount)
    Dim dncell As Range: Set dncell = drrg.Cells(1) _
        .EntireRow.Columns(DST_SOURCE_NAME_COLUMN)
    
    ' Clear existing data.
    
    Dim drCount As Long: drCount = dws.Rows.Count - drrg.Row + 1
    drrg.Resize(drCount).ClearContents
    dncell.Resize(drCount).ClearContents
    
    ' Get the source first file name.
    
    Dim sFileName As String: sFileName = Dir(SRC_FOLDER_PATH & SRC_DIR_PATTERN)
    
    If Len(sFileName) = 0 Then
        MsgBox "No (""" & SRC_DIR_PATTERN & """) files found in """ _
            & SRC_FOLDER_PATH & """!", vbExclamation
        Exit Sub
    End If
    
    ' For each found file, copy...
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, slCell As Range
    Dim sRowsCount As Long, dRowsCount As Long, swsCount As Long
    
    Do While Len(sFileName) > 0
        
        Set swb = Workbooks.Open(Filename:=SRC_FOLDER_PATH & sFileName, Local:=True)
        Set sws = swb.Sheets(1)
        Set slCell = sws.Cells.Find(What: = "Total", LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        
        If Not slCell Is Nothing Then
            sRowsCount = slCell.Row - SRC_TOTALS_ROW_OFFSET - SRC_FIRST_ROW + 1
            If sRowsCount > 0 Then
                Set srg = sws.Rows(SRC_FIRST_ROW) _
                    .Resize(sRowsCount).Columns(SRC_COLUMNS)
                dncell.Offset(dRowsCount).Value = swb.Name ' write workbook name
                drrg.Offset(dRowsCount).Resize(sRowsCount).Value = srg.Value
                dRowsCount = dRowsCount + sRowsCount
                swsCount = swsCount + 1
            'Else ' no data found
            End If
        'Else ' totals row not identified
        End If
        
        swb.Close SaveChanges:=False
        
        sFileName = Dir ' next file
    Loop
    
    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Retrieved " & dRowsCount & " row" _
        & IIf(dRowsCount = 1, "", "s") & " of data from " _
        & swsCount & " file" & IIf(swsCount = 1, "", "s") & ".", _
        vbInformation, PROC_TITLE

End Sub