Loop through worksheets and save key-info to rows in new sheet

Question

I would like to make a piece of code which opens up a bunch of workbooks, pulls out some key data and pastes it into a sort of 'overview' spreadsheet so I can load it in to Access.

Example: I have 3 documents Book1, Book2 and Book3. I would like Cell A1,B2,B4,D6 from sheet1 and B2,B5,E9 from sheet2 and A1:C3 from sheet3 from Book1 to be pasted into row 1 in a new document.

Cell A1,B2,B4,D6 from sheet1 and B2,B5,E9 from sheet2 and A1:C3 from sheet3 from Book2 to be pasted into row 2 in the new document.

And the same from Book3 to be pasted in to row 3 in the new document.

Ect.

I found this code which loops through all worksheets in a folder:

---

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and 
perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
 Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
 myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
 Do While myFile <> ""
 'Set variable equal to opened workbook
  Set wb = Workbooks.Open(Filename:=myPath & myFile)

 'Ensure Workbook has opened before moving on to next line of code
  DoEvents

'SOME SMART CODE SHOULD BE HERE

'Save and Close Workbook
  wb.Close SaveChanges:=True





'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
 Loop

 'Message Box when tasks are completed
 MsgBox "Task Complete!"

 ResetSettings:
'Reset Macro Optimization Settings
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

 End Sub

---

I also found this code which Copy from one workbook and paste into another, but I have a hard time combining those two and get it to work.

Please help!

'SOURCE https://stackoverflow.com/questions/19351832/copy-from-one-workbook-
'and-paste-into-another
Dim x As Workbook, y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

Set x = Workbooks.Open("path to copying book")
Set y = Workbooks.Open("path to pasting book")

Set ws1 = x.Sheets("Sheet you want to copy from")
Set ws2 = y.Sheets("Sheet you want to copy to")

ws1.Cells.Copy ws2.cells
y.Close True
x.Close False

Answer 1

This is extremely literal, based on the problem statement you outlined, but with a little tweaking based on things you know about your actual content, you can probably add in some variables to make this a little less hard-coded.

That said, notionally, I think this is along the lines of what you want:

Dim wb, newWorkbook As Workbook
Dim ws, newWorksheet As Worksheet
Dim idx, row, col As Integer
Dim cell As Range

Set newWorkbook = Workbooks.Add
Set newWorksheet = newWorkbook.Sheets(1)
row = 1

For Each wb In Workbooks

  If wb.Name <> newWorkbook.Name Then
    Set ws = wb.Sheets("Sheet1")
    newWorksheet.Cells(row, 1).Value = ws.Range("A1").Value
    newWorksheet.Cells(row, 2).Value = ws.Range("B2").Value
    newWorksheet.Cells(row, 3).Value = ws.Range("B4").Value
    newWorksheet.Cells(row, 4).Value = ws.Range("D6").Value

    Set ws = wb.Sheets("Sheet2")
    newWorksheet.Cells(row, 5).Value = ws.Range("B2").Value
    newWorksheet.Cells(row, 6).Value = ws.Range("B5").Value
    newWorksheet.Cells(row, 7).Value = ws.Range("E9").Value

    Set ws = wb.Sheets("Sheet3")
    col = 8
    For Each cell In ws.Range("A1:C3")
      newWorksheet.Cells(row, 7).Value = cell.Value
      col = col + 1
    Next cell

    row = row + 1
  End If
Next wb