CODEWITHSUNDEEP
excelvba
Ashok
Ashok

Reputation: 69

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

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

  1. 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.

  1. 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.

  1. Workbook1.xlsx
  2. Workbook2.xlsx
  3. 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.

Upvotes: 0

Views: 987

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

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

Upvotes: 1

Related Questions