VBA : Copy Specific cells from Multiple Workbooks(having Multiple Worksheets) to a single WorkBook

Question

Hope you are doing safe and well. Im new to VBA. We are trying to do the following:

We have multiple workbooks, with 7 Worksheets. Sheet1 to Sheet 8. (Though Sheet 3 to Sheet 8 are not required).

The format of all Sheet1's are same in all Workbooks,

The format of all Sheet2's are same in all Workbooks etc.

We would like to write a VBA code which would do the following: In a separate Output.xlsm Sheet:

a. Copy the value of B2 in Sheet 1 of WorkBook1, paste it in A1 of Output.xlsm

b. Copy the range A3:F8 in Sheet 2 of WorkBook1, paste it in B2 of Outputl.xlsm

c. Then loop through all the other Workbooks and do the same as above, and paste the data one below the other. This is the code we tried: which doesnt really work:

Sub ExportData_MultiFiles()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = ThisWorkbook

Dim ws As Worksheet

Dim L As Long, x As Long
sPath = "E:\downloads\Reports\" '<< files in folder , change path as needed
sFile = Dir(sPath & "*.xls*")
Application.ScreenUpdating = False
Set ws = Sheets.Add(before:=Sheets(1))

Do While sFile <> ""
Set wb2 = Workbooks.Open(sPath & sFile)
For x = 1 To wb2.Sheets.Count

wb1.Sheets(x).Cells(1, 1).Value = wb2.Worksheets("Sheet1").Cells(2, 2).Value
wb1.Sheets(x).Cells(1, 2).Value = wb2.Worksheets("Sheet2").Range("A3:F8").Value


Next
wb2.Close False
sFile = Dir()
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub

Have shared the 3 Workbook files as examples.

Workbook1.xlsx
Workbook2.xlsx
Output.xlsx

https://drive.google.com/drive/folders/1I8nso3t6AfXrbV87cXcrKfJxQM3vaXMT?usp=sharing

We have tried to research many posts in StackOverFlow Would you please guide us on how to complete this.

Thank you in advance.

So, you need to copy from all workbooks from sPath folder, "Sheet1" and "Sheet2" in wb1 workbook. Now, what is not so clear, would be the next: "A1 of Output.xlsm" is not enough. You must tell us in which worksheets. Would you like to copy from each "Sheet1" (Range "A2") in "Sheet1" (wb workbook) range "A1"? And from "Sheet2" to the same "Sheet1" or in "Sheet2"? Then, if in column A:A all new records will be done one after the other, how should proceed for range "A3:F8"? Firstly, in which sheet to be pasted and then, the next workbook range should be pasted after the last row in "B:B"? — FaneDuru
I tried looking in the shared workbooks and nothing looks to match your above explanations... I do not see any workbook example having 8 rows, I can see that 'Output.xlsm' (only one sheet) has in many rows 'abc', 'xyz'... Since you said A3:F8 will be pasted in B2, there also are records on all the first row. Are there column headers already existing? I cannot start preparing a piece of code since I do not exactly understand what you need... — FaneDuru
@FaneDuru: Have shared a few points below : 1. Every Workbook has a Sheet 1 and Sheet2. 2. From every Workbook's Sheet1, the value in cell A2 is necessary to be pasted in Output.xlsm's A2:A7. 3. From every Workbook's Sheet2, the values from range A3:F8 is necessary to be pasted in Output.xlsm's B2:G7 — Ashok
@FaneDuru: Please see this image: drive.google.com/file/d/1gjBl3w5cIe-AaDTb_MaJnSQqDQxaWbEg/… — Ashok

FaneDuru FaneDuru · Accepted Answer · 2020-09-09T18:05:13

Since you did not answer my clarification questions, please try the next code. It will copy all the mentioned ranges in the same newly add sheet. From the new open workbook the ranges will be pasted in first empty row, calculated according to B:B column cells:

Sub ExportData_MultiFiles()
 Dim wb1 As Workbook, wb2 As Workbook, Spath As String, sFile As String
 Dim lastRow As Long, ws As Worksheet

 Set wb1 = ThisWorkbook

 Spath = "E:\downloads\Reports\" '<< files in folder , change path as needed
 sFile = Dir(Spath & "*.xls*")
 Application.ScreenUpdating = False
 Set ws = wb1.sheets.Add(Before:=sheets(1))

 Do While sFile <> ""
    Set wb2 = Workbooks.Open(Spath & sFile)
    lastRow = ws.Range("B" & rows.count).End(xlUp).row + 1
    ws.Range("A" & lastRow).Resize(6, 1).value = wb2.Worksheets("Sheet1").Range("B2").value
    ws.Range("B" & lastRow).Resize(6, 6).value = wb2.Worksheets("Sheet2").Range("A3:F8").value

    wb2.Close False
    sFile = Dir()
 Loop
 ActiveWorkbook.Save
 Application.ScreenUpdating = True
End Sub

VBA : Copy Specific cells from Multiple Workbooks(having Multiple Worksheets) to a single WorkBook

1 Answers