Блог

Главная - Вопросы по программированию - Просмотрите несколько файлов в папке и скопируйте/вставьте в главный файл

Просмотрите несколько файлов в папке и скопируйте/вставьте в главный файл

#excel #vba

Вопрос:

Мне нужно скопировать из нескольких файлов в определенную папку и вставить в основной файл. Все файлы имеют лист под названием «Анализ», переменные строки, но постоянные столбцы. Мне нужно скопировать из всех файлов лист «Анализ» A4:AB и вставить в рабочую книгу под названием «Оценки» на листе под названием «Оценки» G2:АХ, один под другим. У меня есть приведенный ниже код, который работал, но больше не работает, и я не знаю почему. Не могли бы вы, пожалуйста, помочь?

 Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim lastRow As Long
    Const strPath As String = "V:Trade MarketingTrade Finance2021ProjectsEvaluationAnalysis"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath amp; strExtension)
        With wkbSource
                    lastRow = .Sheets("Analysis").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("Analysis").Range("A4:AB" amp; lastRow).Copy wkbDest.Sheets("Evaluations").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
            .Close SaveChanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Комментарии:

1. Вы получили какое-либо сообщение об ошибке? Если да, то в какой строке?

2. У вас есть 2 способа определения последней строки, я бы рекомендовал использовать способ, который вы используете при вставке, также для определения диапазона копирования.

3. Привет, Рэймонд, спасибо, что связался. Я не получил никакого сообщения об ошибке. Я пытаюсь запустить его, но он ничего не делает.

4. Привет, Натан, спасибо за твое сообщение. Я по-прежнему не получаю никакого ответа при запуске кода.

5. Вы прошли через код, чтобы увидеть, что происходит? Есть ли там файлы? Их открывают?

Ответ №1:

Столбцы резервных копий Данных

 Option Explicit

Sub AnalysisBackup()
    
    Const swbPath As String _
        = "V:Trade MarketingTrade Finance2021ProjectsEvaluationAnalysis"
    Const swbPattern As String = "*.xls*"
    
    Const sName As String = "Analysis"
    Const sCols As String = "A:AB"
    Const sFirstRow As Long = 4
    
    Const dName As String = "Evaluations"
    Const dFirst As String = "G2"
    
    Dim swbName As String: swbName = Dir(swbPath amp; swbPattern)
    If swbName = "" Then Exit Sub ' no file found
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
    Dim cCount As Long: cCount = dws.Columns(sCols).Columns.Count
    Dim dirrg As Range: Set dirrg = dws.Range(dFirst).Resize(, cCount)
    Dim drrg As Range ' Destination First Row Range
    Dim dlCell As Range ' Destination Last Cell
    Set dlCell = dirrg.Resize(dws.Rows.Count - dirrg.Row   1) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If dlCell Is Nothing Then
        Set drrg = dirrg
    Else
        Set drrg = dirrg.Offset(dlCell.Row - dirrg.Row   1)
    End If
            
    Dim swb As Workbook ' Source Workbook
    Dim sws As Worksheet ' Source Worksheet
    Dim srg As Range ' Source Range
    Dim slCell As Range ' Source Last Cell
    Dim srCount As Long ' Source Range Rows Count
    
    Dim drg As Range ' Destination Range
    
    Application.ScreenUpdating = False
    
    Do While swbName <> ""
        Set swb = Workbooks.Open(swbPath amp; swbName)
        Set sws = Nothing
        On Error Resume Next
        Set sws = swb.Worksheets(sName)
        On Error GoTo 0
        If Not sws Is Nothing Then
            Set slCell = Nothing
            With sws.Rows(sFirstRow).Columns(sCols)
                Set slCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
                    .Find("*", , xlFormulas, , xlByRows, xlPrevious)
                If Not slCell Is Nothing Then
                    srCount = slCell.Row - .Row   1
                    Set srg = .Resize(srCount)
                    Set drg = drrg.Resize(srCount)
                    drg.Value = srg.Value
                    Set drrg = drrg.Offset(srCount)
                'Else ' empty source range
                End If
            End With
        'Else ' source worksheet does not exist
        End If
        swb.Close SaveChanges:=False
        swbName = Dir
    Loop
    
    'dwb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Analysis backup created.", vbInformation, "Analysis Backup"
    
End Sub
Метки: