Extracting from many excel sheets to a master document, Help

Hi, RoyLittle0,

JBeaucaire WBs to 1 Sheet or Ron de Bruin Merge data from all workbooks in a folder and RDBMerge, Excel Merge Add-in for Excel for Windows might be good ressources.

Ciao,
Holger

Thanks Ciao

I have looked at the options and think that "WBs to 1 Sheet" is suitable but this code copies Ranges, what I need to do is many individual Cells and also to have a header row, i think the section I have extracted is what I need to alter

 'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If

Option Explicit

Sub Consolidate()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

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("Master")    '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)
    fPath = "C:\2011\Files\"            '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
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If
        fName = Dir                                       'ready next filename
    Loop
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

Hi, RoyLittle0,

what I need to do is many individual Cells and also to have a header row

Imagine you don´t know your workbook: how would you know what to alter and how? Maybe think about attaching a sample workbook with one or two sample sheets as they look and the cells which need to be copied and the desired result on another sheet.

Ciao,
Holger

Originally Posted by HaHoBe

Hi, RoyLittle0,


Imagine you don´t know your workbook: how would you know what to alter and how? Maybe think about attaching a sample workbook with one or two sample sheets as they look and the cells which need to be copied and the desired result on another sheet.

Ciao,
Holger

HaHoBe,

Both the Weekly Record 2013 Master Rev 1.xlsx (500+) which is where I want to take the data from and the FSR Master.xlsx (Post #6) that I will be collating the information on have been uploaded to the post in the General Forum, with the link on the first post, the FSR Master.xlsx shows what data I need and the corresponding cell on the Weekly Record 2013 Master Rev 1.xlsx where I need to get the information from.

Roy

Hi, Roy,

no need to quote full posts if they are located directly above.

I downloaded both workbooks. As I understand it (please correct me here when I´m wrong) you want to load the information from workbooks like Weekly Record 2013 Master Rev 1.xlsx into FSR Master.xlsx. You have inserted the cell addresses you want to copy and that´s where I start having trouble: Column A for FSR states E12 while E12 in Weekly Record shows part of the job number. I´m afraid I won´t be of any help except here as the result won´t tell me I have done everything correctly. So i think I show you how I would try to adjust the code from Jerry.

Origional part about copying is

        'This is the section to customize, replace with your own action code as needed
            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)

Code is untested as I do have problems with adjusting to find what from where should be inserted:

Sub Consolidate_937091()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
Dim arrCells                                          As Variant
Dim lngArray                                          As Long

'###build an array holding the addresses of the cells to copy
arrCells = Array("E12", "F15", "F16", "F17", "I20", "W10", "V12")   '###more cells as I didn´t enter all of them

'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("Master")    '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)
    fPath = "C:\2011\Files\"            '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
            '### loop through the array. As the lower bound is 0 we need to add 1 for the column to write to
            For lngArray = LBound(arrCells) To UBound(arrCells)
              .Cells(NR, lngCounter + 1).Value = Range(arrCells(lngCounter)).Value
            Next lngArray
'        'This is the section to customize, replace with your own action code as needed
'            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
'            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If
        fName = Dir                                       'ready next filename
    Loop
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

And you would need to save the master workbook as a macro-enabled workbook with the suffix xlsm in order to hold the code (code should be inserted into a standard module).

Ciao,
Holger

Hi, Roy,

as I didn´t test the code I use a wrong variable as loop counter in the array - sorry for that.

What I did: copied both the macro enabled workbook FSR Master as well as three copies of the newly supplied workbook into a test folder. FSR Master was open, the following code was run

Sub Consolidate_937091_Take2()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
'Summary:    Merge files in a specific folder into one master sheet (stacked)
'            Moves imported files into another folder

Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
Dim arrCells                                          As Variant
Dim lngArray                                          As Long

'###build an array holding the addresses of the cells to copy
arrCells = Array("E12", "F15", "F16", "F17", "I20", "W10", "V12", "T13", "L38")
'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("Master")    '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)
    fPath = ThisWorkbook.Path & "\"            'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
'    fPath = "C:\2011\Files\"            '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
            '### loop through the array. As the lower bound is 0 we need to add 1 for the column to write to
            For lngArray = LBound(arrCells) To UBound(arrCells)
              .Cells(NR, lngArray + 1).Value = Range(arrCells(lngArray)).Value
            Next lngArray
            .Cells(NR, 10).Value = IIf(ActiveSheet.Shapes("Check Box 10").ControlFormat.Value = 1, "True", "False")
            .Cells(NR, 11).Value = Range("S14").Value
            .Cells(NR, 12).Value = Range("A23").Value
            .Hyperlinks.Add Anchor:=.Cells(NR, "M"), _
                Address:=fPathDone & Replace(fName, " ", "%20"), _
                TextToDisplay:=fName
'        'This is the section to customize, replace with your own action code as needed
'            LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
'            Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR)
            wbData.Close False                                'close file
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
            Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
        End If
        fName = Dir                                       'ready next filename
    Loop
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

I changed the drive and the path for the folder to be identical with the workbook with code.

Ciao,
Holger