VBA copy and paste multiple cells, without overwriting existing information

Question

I have multiple excel books that i need to extract data from and put it in a consolidated view. I have been trying to copy and paste different cells from one workbook and paste them to another. I managed to do that with one cell but i am not too sure how to do it for multiple cells (not a range, though)?

Lets say I have 5 files. I loop through them and I want Cell F18 to be copied to Cell A1 and Cell F14 to be copied to B1...Then go to the next file and do the same but append the information on the next blank row.

Here is the code i am using

Sub AllFiles()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook

folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
  Application.ScreenUpdating = False
    Set wb = Workbooks.Open(folderPath & filename)


   'copy name (cell F18 and paste it in cell A2)
    Range("F18").Copy

    'copy client (cell F14 and paste it to B2)

         Application.DisplayAlerts = False
        ActiveWorkbook.Close

        emptyRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 1), Cells(emptyRow, 2))

    filename = Dir
Loop

Application.ScreenUpdating = True End Sub

Joe Joe · Accepted Answer · 2014-01-27T16:30:00

Your code looks incomplete; it's only copying one cell, and I don't see where it's overwriting the previous value. I also got a warning since the code is copying from one cell but pasting into two.

I would take a different approach. Instead of copying/pasting, I would just set the value of the target cells to match the source, then move the target down one row each time, rather than checking for the last populated row:

Sub AllFiles()
    Dim folderPath As String
    Dim filename As String
    Dim wb As Workbook

    folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

    filename = Dir(folderPath & "*.xlsx")

    Dim targetCell As Range: Set targetCell = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

    Do While filename <> ""
        Set wb = Workbooks.Open(folderPath & filename)

        targetCell.Value = Range("f18").Value
        targetCell.Offset(0, 1) = Range("f14").Value
        Set targetCell = targetCell.Offset(1, 0)

        ActiveWorkbook.Close
        filename = Dir
    Loop
End Sub

VBA copy and paste multiple cells, without overwriting existing information

1 Answers