Macro to Extract Specific cell data from Multiple Worksbooks into one summary.

[Dreamwrx]

Hi,

I have a bunch of excel files (3000) that I need to extract data from specific Cells in these spreadsheet and paste them to a summary sheet.

Q10:V10 -> B8:G8;
Q13:V13 -> H8:M8;
Q16:V16 -> N8-S8;
B14 -> A8

Next Spreadsheet would be
Q10:V10 -> B9:G9;
Q13:V13 -> H9:M9;
Q16:V16 -> N9:S9;
B14 -> A8

so on and so forth.

I have been reading multiple older forum posts and have tried some things but as I am not proficient at VB.. I seem to be stuck.

The following was what I was using. Most of it was from Jerry Beaucaire's code

Sub Retrieve_Data()
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet

'Setup
    Application.ScreenUpdating = False  'speed up macro execution
    Application.EnableEvents = False    'turn off other macros for now
    Application.DisplayAlerts = False   'turn off system messages for now
   
    Set wsMaster = ThisWorkbook.Sheets("AVG")    'sheet report is built into

With wsMaster
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        .UsedRange.Offset(1).EntireRow.Clear
        NR = 2
    Else
        NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
    End If

'Path and filename (edit this section to suit)
   ' MsgBox "Please select a folder with files to consolidate"
   ' Do
   '     With Application.FileDialog(msoFileDialogFolderPicker)
   '         .InitialFileName = "C:\2010\Test\"
   '         .AllowMultiSelect = False
   '         .Show
   '         If .SelectedItems.Count > 0 Then
   '             fPath = .SelectedItems(1) & "\"
   '             Exit Do
   '         Else
   '             If MsgBox("No folder chose, do you wish to abort?", _
   '                 vbYesNo) = vbYes Then Exit Sub
   '         End If
   '     End With
   ' Loop
   fPath = "C:\Users\htn\Desktop\Macro_Test\"                  'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xls*")       'listing of desired files, edit filter as desired

'Import a sheet from found files
    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
            Set wbData = Workbooks.Open(fPath & fName)  'Open file
        'This is the section to customize, replace with your own action code as needed
            Dim ws As Worksheet
            For Each ws In wbData.Sheets(Array("Flow_Level"))
                LR = Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
                If LR > 3 Then
                    wsMaster.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
                        Range("Q10:V10").Copy
                    wsMaster.Range("B8" & NR).PasteSpecial xlPasteValues, Transpose:=True
                    wbData.Close False                                'close file
                    NR = wsMaster.Range("B" & Rows.Count).End(xlUp).Row + 1
                End If
   
   
    Next ws
        ' wbData.Close False   'close data workbook
        ' fName = Dir         'get the next filename
        Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If
        fName = Dir                                       'ready next filename
    Loop
   
    Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    With Range("A3:A" & NR - 1)
    .Value = .Value
    End With
End With
ErrorExit:    'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub

Thank you for any help in advance.

 

[Ana_kin]

Please start a new thread.

@John_w , Here is the thread. Thanks for replying.

Macro to Extract Specific cell data from Multiple CSV files in a folder into a new summary Excel file

Hi, I have a a folder with 100 csv files from specific Cells and paste them to a summary excel file. For example- from origin_file_1.csv to the dest_file.xlsm B7-->K2 B8-->L2 B10--> M2 from origin_file_2.csv to the dest_file.xlsm B7-->K3 B8-->L3 B10--> M3 and so forth. Thanks in...

www.mrexcel.com