VBA - Loop through files in a folder AND copy single cells as well as a range, if condition is met

Question

I am currently using a piece of code to loop through files in a folder and copy certain cells from each file into a master list. There are a number of files being added into the folder every week. One of the columns in the master list includes the filenames of previously looped files. The code only loops through files that are not included in the filename list and therefore also have not previously been looped.

The code works really well and copies cells with satisfactory results however I now need to modify it to also copy a range of data (A20:H33 specifically) as well as meeting the above condition of not already being looped.

I have tried the following unsuccesfully:

• Adding another varTemp to the code (As seen in the main code)
• Adding a sub that can copy a range (However I have been unable to incorporate this into the code so it satisfies the not looped condition)
• Using selection.copy and selection.paste however an error that I cannot workaround pops up ("Object doesn't support this property or method")

Here is the main code:

    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

This is the snippet of code that when inserted into the main code just below tha last vartemp gives me the following error ("Object doesn't support this property or method")

.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

Here is what I am trying to achieve:

Answer 1

I think that if you use a Range variable instead of a Variant to copy and paste the Range(A20:AH33) should get the job done. Declare:

Dim rg as Range

Then replace this line of code:

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

For this:

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

Then you can just Rg.Copy and paste whereaver you want. Don't forget to "clear" the copybuffer after you paste the information:

Application.CutCopyMode = False 

Avoid to use Selectionand Activate in your code, the reasons for it can be seen here:

How to avoid using Select in Excel VBA

and here:

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

Answer 2

This should do it. I've turned your array back to 5 elements, and the range is transferred separately. I've added a few new variables which you might want to give more meaningful names.

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