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

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