Macro to compile a list in another workbook

[neelio]

I am trying to run a macro that will take certain cell info and paste into another workbook so I can make a list of specific info. I have recorded a macro of what I want but this wont automatically paste into the next line on my new workbook. I basically want to save my self from having to copy & paste loads of stuff as I am creating a database of info from now that will take info from 100's of previous sheets, & I don't want to have to go through each one copying & pasting, rather I just want to open run the macro then move on to the next.

Can anyone help? Here is the recorded macro but this is only going to get info from one sheet & only into 1 specific location which is no good. Im only in the learning stages of the code so really appreciate any guidance.


Sub Macro1()
'
Windows("Q5385.xls").Activate
ActiveWindow.SmallScroll Down:=-9
Range("D4:F4").Select
Selection.Copy
Windows("Examples.xls").Activate
Range("A13").Select
ActiveSheet.Paste
Windows("Q5385.xls").Activate
Range("D12").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Examples.xls").Activate
Range("L13").Select
ActiveSheet.Paste
End Sub

[mancubus]

i assume the same ranges, Range("D4:F4") and Range("D12"), from all worksheets in Q5385.xls will be copied to the same columns, Columns A-C and Column L, one after another in Examples.xls.



Sub Copy_From_All_WSs_In_Another_WB()


Dim ws As Worksheet, LR As Long

For Each ws In Workbooks("Q5385.xls")
With Workbooks("Examples.xls").Worksheets("WSNameInExamples") 'CHANGE TO ACTUAL WS NAME
LR = .Range("A" & Rows.Count).End(xlUp).Offset(1).Row
.Range("A" & LR & ":C" & LR).Value = ws.Range("D4:F4").Value
.Range("L" & LR).Value = ws.Range("D12").Value
End With
Next


End Sub

[neelio]

I have sought another way round using (of course) Ron de Bruin code. I have used the following & changed to my sheet names ets, but the only thing that it is pulling is the filename & none of the data, Would you guys know what I need to change to pull in the data I need?


Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "Sheet1" '<---- Change
Set Rng = Range("A1,D5:E5,Z10") '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Use this sheet for the Summary
Set SummWks = Sheets("Sheet2") '<---- Change

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbBlue
Else
'Do nothing
End If

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

[neelio]

This is what got it working in the end



Sub Summary_cells_from_Different_Workbooks_2()
'This example use the function LastRow
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range, fndFileName As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
ShName = "Gravity" '<---- Change
Set Rng = Range("D4,D3,D5,E9,E8,L4,M34,M39,I3,D12,I12,H12") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Use this sheet for the Summary
Set SummWks = Sheets("Gravity") '<---- Change
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = LastRow(SummWks) + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'If the workbook name already exist the row color will be Blue
Set fndFileName = Nothing
Set fndFileName = SummWks.Cells.Find(JustFileName)
If Not fndFileName Is Nothing Then

Else
'Do nothing
End If
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" _
& ShName & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1") _
.Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet name not exist the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
'Insert the formulas
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = "=" _
& PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width
SummWks.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

[snb]

That's an incredible amount of code to perform a simple task:


Sub M_snb()
ReDim sn(1 To Workbooks("Q5385.xls").Sheets.Count, 1 To 11)
sp = Split(" D4 D3 D5 E9 E8 L4 M34 M39 I3 D12 I12 H12")

For j = 1 To Workbooks("Q5385.xls").Sheets.Count
For jj = 1 To 11
sn(j, jj) = Workbooks("Q5385.xls").Sheets(j).Range(sp(jj)).Value
Next
Next

Workbooks("Examples.xls").Sheets(1).Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[neelio]

It is, but this way I can simply select all the files I want info from & its all done in one operation. I am prompted for which files I want to draw info from, & can select them all. I may be wrong but I think that the above is just for "Q5385", where I have hundreds of files starting with Q to get info from. I am however always grateful for help & suggestions I receive,