VBA - Проходить по файлам в папке И копировать отдельные ячейки, а также диапазон, если выполняется условие

Question

В настоящее время я использую фрагмент кода для циклического просмотра файлов в папке и копирования определенных ячеек из каждого файла в основной список.Есть несколько файлов, которые добавляются в папку каждую неделю.Один из столбцов в основном списке содержит имена ранее зацикленных файлов.Код перебирает только те файлы, которые не включены в список имен файлов и, следовательно, ранее не были зациклены.

Код работает очень хорошо и копирует ячейки с удовлетворительными результатами, однако теперь мне нужно изменить его, чтобы также копироватьдиапазон данных (особенно A20:H33), а также удовлетворение вышеуказанному условию отсутствия зацикливания.

Я безуспешно пытался выполнить следующее:

• Добавление еще одного varTempк коду (как видно из основного кода)
• Добавление подпрограммы, которая может копировать диапазон (однако я не смог включить это в код, чтобы оно удовлетворяло условию без зацикливания)
• Используя selection.copy и selection.paste, однако появляется ошибка, которую я не могу обойти («Объект не поддерживает это свойство или метод»)

Вот основной код:

    Option Explicit

    Sub CopyFromFolderExample()

    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim strFolder As String, strFile As String, r As Long, wb As Workbook
    Dim varTemp(1 To 6) As Variant

    Application.ScreenUpdating = False
    strFolder = "D:\Other\folder\"

        r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

        strFile = Dir(strFolder & "*.xl*")
        Do While Len(strFile) > 0
            If Not Looped(strFile, ws) Then
                Application.StatusBar = "Reading data from " & strFile & "..."
                Set wb = Workbooks.Add(strFolder & strFile)
                With wb.Worksheets(1)
                    varTemp(1) = strFile
                    varTemp(2) = .Range("A13").Value
                    varTemp(3) = .Range("H8").Value
                    varTemp(4) = .Range("H9").Value
                    varTemp(5) = .Range("H37").Value
                    'varTemp(6) = .Range("A20:H33").Value

                End With
                wb.Close False

                r = r + 1
                ws.Range(ws.Cells(r, 1), ws.Cells(r, 6)).Formula = varTemp
            End If    
          strFile = Dir
        Loop

    Application.StatusBar = False
    Application.ScreenUpdating = True

    End Sub

    Private Function Looped(strFile As String, ws As Worksheet) As Boolean

    Dim Found As Range
    Set Found = ws.Range("A:A").Find(strFile)

    If Found Is Nothing Then
        Looped = False
    Else
        Looped = True
    End If

    End Function

Это фрагмент кода, который при вставке в основной код чуть ниже последнего vartemp дает мне следующую ошибкуr («Объект не поддерживает это свойство или метод»)

.Range("A20:H33").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

ws.Activate

If ws.Range("A1") = "" Then
    ws.Range("A1").Select
    Selection.Paste
Else
    Selection.End(xlDown).Offset(6, 0).Select
    Selection.Paste
End If

Вот что я пытаюсь достичь:

Answer 1

Это должно сделать это.Я превратил ваш массив обратно в 5 элементов, и диапазон передается отдельно.Я добавил несколько новых переменных, которые вы могли бы дать более значимым именам.

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 5) As Variant, r1 As Long, r3 As Range

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
strFile = Dir(strFolder & "*.xl*")

Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = strFile
            varTemp(2) = .Range("A13").Value
            varTemp(3) = .Range("H8").Value
            varTemp(4) = .Range("H9").Value
            varTemp(5) = .Range("H37").Value
            Set r3 = .Range("A20:H33")
        End With
        With ws
            r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            r1 = .Range("F" & .Rows.Count).End(xlUp).Row + 1 'last used row in col F
            .Range(.Cells(r, 1), .Cells(r, 5)).Value = varTemp
            .Cells(r1, 6).Resize(r3.Rows.Count, r3.Columns.Count).Value = r3.Value 'transfer A20:H33
        End With
        wb.Close False
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

End Sub

Answer 2

Я думаю, что если вы используете переменную Range вместо Variant для копирования и вставки Range(A20:AH33), работа должна быть выполнена.Объявите:

Dim rg as Range

Затем замените эту строку кода:

varTemp(6) = .Range("A20:H33").Value

Для этого:

Set rg = .Range("A20:H33")

Тогда вы можете просто Rg.Copy и вставить куда угодно.Не забудьте "очистить" буфер копирования после вставки информации:

Application.CutCopyMode = False 

Избегайте использования Selection и Activate в своем коде, причины этого можно увидеть здесь:

Как избежать использования Select в Excel VBA

и здесь:

https://www.businessprogrammer.com/power-excel-vba-secret-avoid-using-select/