Thread: Get data from diferent workbooks to a single workbook

The edit was not meant to arm anyone, i simply erase the lines in the top of the macro, i already edited the code and putted it back.

i opened a new thread since the original one was solved, nevertheless , lesson learned !

the code is like this at the moment :

Sub CollectInfoFinal()

'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      10/21/2010
'Summary:   Collect specific data from all workbooks in a single folder

Dim fPath As String
Dim fName As String
Dim wbData As Workbook
Dim wsDest As Worksheet:    Set wsDest = ThisWorkbook.Sheets("stock")
Dim NR As Long:             NR = wsDest.Range("B" & Rows.Count).End(xlUp).Row + 1
Dim LR As Long
   
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\"
    .Show
    If .SelectedItems.Count > 0 Then
        fPath = .SelectedItems(1)
    Else
        MsgBox "Folder selection cancelled", vbInformation, Title:="Process Cancelled"
        Exit Sub
    End If
End With

Application.ScreenUpdating = False      'speed up macro
fName = Dir(fPath & "\*.xls")            'filter for files to open

Do While Len(fName) > 0
    Set wbData = Workbooks.Open(fPath & "\" & fName)  'open found file
    With wbData.Sheets("Resumo")
        .Rows(10).AutoFilter
        .Rows(10).AutoFilter Field:=6, Criteria1:=">0.5"
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        If LR > 10 Then
            wsDest.Range("A" & NR).Value = .[A5]
            wsDest.Range("E" & NR).Value = .[D2]
            .Range("A11:A" & LR & ",F11:F" & LR & ",K11:K" & LR).Copy
            wsDest.Range("B" & NR).PasteSpecial xlPasteValuesAndNumberFormats
            wsDest.Range("F" & NR).Value = .[C*E]
            
        End If
    End With
    wbData.Close False
    NR = Range("B" & Rows.Count).End(xlUp).Row + 1
    fName = Dir
Loop

LR = Range("B" & Rows.Count).End(xlUp).Row
With Range("A1:E" & LR)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Run [teorico()]
Run [real()]

Columns.AutoFit
Application.ScreenUpdating = True

End Sub

yes , its true ...its never final ....
now i am checking some more details e want to add .... to rename the sheet with the actual date and some more small things that are now growing in my mind. but the main thing was the code you gave me ! without it ....
once again Thanks

missed to post the code for the 2 sub macros i inserted in the main code :

Sub teorico()
Dim r As Range
Set r = Range("F2", Cells(Rows.Count, "F").End(xlUp)).Offset(0, 0)
r.Formula = "=C2*E2"
r.Copy
r.PasteSpecial xlValues
End Sub

Sub real()
Dim r As Range
Set r = Range("F2", Cells(Rows.Count, "F").End(xlUp)).Offset(0, 1)
r.Formula = "=D2*E2"
r.Copy
r.PasteSpecial xlValues
End Sub