Merging Data from Multiple workbooks into a summary sheet with 5 Worksheets

[13bowerm]

A fairly complex bit of coding here - hats off to anyone able to do it.

I have multiple workbooks in a specified folder that I need to summarise in a summary workbook. These workbooks contain data in 5 categories on one sheet (capital, resource, etc), and I need to summarise each category on a different sheet in the summary workbook.

The files in the source folder are always changing, so there needs to be a loop function. I can summarise data onto 1 summary sheet in the summary workbook, but can't seem to split the data between 5 sheets in the new book (my coding skills are very basic).

To summarise, I need to be able to select 5 different data ranges (capital, resource... etc) on each of the source workbooks, and move each range onto different sheets in the summary workbook (titled capital, resource... etc).

Any help would be greatly appreciated!

 

[D3allamerican07]

13bowerm,

The following code lets the user select what workbooks to loop through, then prompts the user to select 5 different ranges per workbook.

In order for the code to function properly, make sure the 5 variable names for shtName (Capital, Resources, etc.) match the 5 sheets in your summary workbook. You will need to change "Header3", "Header4", and "Header5" accordingly.

In order to run, make sure the only workbook open is the Summary workbook and ensure all sheet names match the code.

Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        For i = LBound(fileSelect) To UBound(fileSelect)
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
            
                For j = 1 To 5
                
                    If j = 1 Then
                        shtName = "Capital"
                    ElseIf j = 2 Then
                        shtName = "Resources"
                    ElseIf j = 3 Then
                        shtName = "Header3"
                    ElseIf j = 4 Then
                        shtName = "Header4"
                    Else
                        shtName = "Header5"
                    End If
                    
                     
                    LR = Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & Rows.Count).End(xlUp).Row
                    
                    Set rng = Application.InputBox("Select a range for " & shtName, "Obtain Range Object for " & fileSelect(i), Type:=8)
                    rng.Copy Destination:=Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & LR + 1)
            
                Next j
            wbkToCopy.Close savechanges:=False
        Next i
    End If

End Sub

Let me know if you have any questions or you want to make the ranges automatically copy and paste over.

Bill

 

[D3allamerican07]

The following code will also copy and paste all data into the Summary sheet in the Summary workbook. Make sure the range matches in A:E.

Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        For i = LBound(fileSelect) To UBound(fileSelect)
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
            
                currentLR = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
                LR = Workbooks("Summary.xlsx").Sheets("Summary").UsedRange.Rows(Workbooks("Summary.xlsx").Sheets("Summary").UsedRange.Rows.Count).Row
                [COLOR=#ff0000][B]Range("A2:E" & currentLR).Copy[/B][/COLOR] Destination:=Workbooks("Summary.xlsx").Sheets("Summary").Range("A" & LR + 1)
                
                For j = 1 To 5
                
                    If j = 1 Then
                        shtName = "[B][COLOR=#ff0000]Capital[/COLOR][/B]"
                    ElseIf j = 2 Then
                        shtName = "[B][COLOR=#ff0000]Resources[/COLOR][/B]"
                    ElseIf j = 3 Then
                        shtName = "[B][COLOR=#ff0000]Header3[/COLOR][/B]"
                    ElseIf j = 4 Then
                        shtName = "[B][COLOR=#ff0000]Header4[/COLOR][/B]"
                    Else
                        shtName = "[B][COLOR=#ff0000]Header5[/COLOR][/B]"
                    End If
                    
                     
                    LR = Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & Rows.Count).End(xlUp).Row
                    
                    Set rng = Application.InputBox("Select a range for " & shtName, "Obtain Range Object for " & fileSelect(i), Type:=8)
                    rng.Copy Destination:=Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & LR + 1)
                    
                Next j
            wbkToCopy.Close savechanges:=False
        Next i
    End If

MsgBox "Task Complete"

End Sub

 

[13bowerm]

Thank you very much for this, I think I'm nearly there, but am held back by my coding skills somewhat...

Could you make it more clear where I change the file path & file name in your code?

Also, I need 5 different ranges from the source sheets (A1:G1, A2:G2, etc). Each range must go on to a different sheet, can you make it clear where I change these ranges too?

Sorry if this is asking a lot, but it is hugely appreciated!

Thanks

 

[D3allamerican07]

No worries!

The code does not need a specific file path, it will allow you to select which 5 files you need to open (since the files in the source folder are always changing).

The 5 different ranges will now automatically be pasted in their responsible sheet. You will need to make sure in the code (line 36 - 44) the values match the sheet names in the Summary workbook. These values are highlighted in red. (Capital, Resources, etc.)

Make sure the Summary workbook is open and all other source files are closed. The Summary workbook should be set up with 6 sheets (Summary, Capital, Resources, etc.). If set up correctly, it should run smoothly.

Sub LoopThroughFiles()
    Dim rng As Range
    Dim shtName As String
    Dim fileSelect As Variant
    Dim i As Long
    Dim j As Long
    Dim wbkToCopy As Workbook
    
    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'Prompts user to select 5 source files
    fileSelect = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", Title:="Select files", MultiSelect:=True)
    
    If IsArray(fileSelect) Then
        'Loops through 5 source files
        For i = LBound(fileSelect) To UBound(fileSelect)
            'Opens source file
            Set wbkToCopy = Workbooks.Open(Filename:=fileSelect(i))
                
                'Finds last row of source file
                currentLR = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
                
                'Finds last row of Summary sheet
                LR = Workbooks("Summary.xlsx").Sheets("Summary").UsedRange.Rows(Workbooks("Summary.xlsx").Sheets("Summary").UsedRange.Rows.Count).Row
                
                'Copies range from source file to Summary sheet
                Range("A2:G" & currentLR).Copy Destination:=Workbooks("Summary.xlsx").Sheets("Summary").Range("A" & LR + 1)
                
                'Loops through each range
                For j = 1 To 5
                
                    'Determines which sheet to paste in
                    If j = 1 Then
                        shtName = "[COLOR=#ff0000][B]Capital[/B][/COLOR]" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 2 Then
                        shtName = "[COLOR=#ff0000][B]Resources[/B][/COLOR]" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 3 Then
                        shtName = "[COLOR=#ff0000][B]Header3[/B][/COLOR]" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 4 Then
                        shtName = "[COLOR=#ff0000][B]Header4[/B][/COLOR]" 'Ensure sheet name matches sheet in the Summary workbook
                    Else
                        shtName = "[COLOR=#ff0000][B]Header5[/B][/COLOR]" 'Ensure sheet name matches sheet in the Summary workbook
                    End If
                    
                    'Finds last row of variable sheet
                    LR = Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & Rows.Count).End(xlUp).Row
                    
                    'Sets range according to variable sheet
                    Set rng = ActiveSheet.Range("A" & i & ":" & "G" & i)
                    
                    'Determines which row to paste in
                    If Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & LR).Value = "" Then
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & LR)
                    Else
                        'Copies range from source file to Summary sheet
                        rng.Copy Destination:=Workbooks("Summary.xlsx").Sheets(shtName).Range("A" & LR + 1)
                    End If
                    
                Next j
            'Closes and does NOT save source file
            wbkToCopy.Close savechanges:=False
        Next i
    End If
    
    MsgBox "Task Complete"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Let me know if you have any issues.

Bill

 

[13bowerm]

Hi Bill,

Sorry if I did not make myself exactly clear, but although the source file names are different and new files get added etc, they follow the same format of T(x) Data Form. X being a number. I have about 50 files that I need to collect the data from, so selecting the individual ones may take some time!

I believe you can loop through files in a folder- here's a previous code I used which looped through the correct files, but I couldn't move the data onto different tabs in the summary.

Here is part of it;


FolderPath = "\Documents\DCFs\Cross checked"



' NRow keeps track of where to insert new rows in the destination workbook.

NRow = 3



' Call Dir the first time, pointing it to all Excel files in the folder path.

FileName = Dir(FolderPath & "*Data Capture Form*.xl*")



' Loop until Dir returns an empty string.

Do While FileName <> ""

' Open a workbook in the folder

Set WorkBk = Workbooks.Open(FolderPath & FileName)



' Set the cell in column A to be the file name.

SummarySheet.Range("A" & NRow).Value = FileName

Set SourceRange = WorkBk.Worksheets("Costs And Benefits").Range("G16:I16")





' Set the destination range to start at column B and

' be the same size as the source range.

Set DestRange = Capital.Range("B" & NRow)

Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _

SourceRange.Columns.Count)





' Copy over the values from the source to the destination.

DestRange.Value = SourceRange.Value



' Increase NRow so that we know where to copy data next.

NRow = NRow + DestRange.Rows.Count



' Close the source workbook without saving changes.

WorkBk.Close savechanges:=False



' Use Dir to get the next file name.

FileName = Dir()

Loop

I want to use this sort of code, but to be able to select 5 different ranges (instead of the one above, G16:I16) and to move those 5 ranges from each Data Form onto different tabs in the summary sheet.

Getting close now! Thank you so much I really appreciate the help!

Ron

 

[D3allamerican07]

13bowerm,

Alright, the following code will:

• Loop through the folder (\Documents\DCFs\Cross checked\) copying ranges from files with (T(x) Data Form) as the file name.
  • Note: With this method, the file name must stay in the format above otherwise it will NOT open
  • Check the highlighted red portion of the cope to ensure the paths are correct
  • Right click on the file name and click properties to check path if not known
• It will copy and paste all ranges in each source file to a summary sheet in the Summary workbook
• It will copy and paste range ("A1:G1") to sheet named "Capital"
• It will copy and paste range ("A2:G2") to sheet named "Resources"
• It will copy and paste range ("A3:G3") to sheet named "Header3"
• It will copy and paste range ("A4:G4") to sheet named "Header4"
• It will copy and paste range ("A5:G5") to sheet named "Header5"
  • In order for these ranges to change, you will need to alter the variables in the code where the sheet names are listed (line 27-35)

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "[B][COLOR=#ff0000]\Documents\DCFs\Cross checked\[/COLOR][/B]" 'Folder path
    ChDir strPath
    strExtension = Dir("[B][COLOR=#ff0000]T(*" & ") Data Form" & ".xl*[/COLOR][/B]") 'File name with extensions
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
        
                'Finds last row of source file
                currentLR = wkbSource.ActiveSheet.UsedRange.Rows(wkbSource.ActiveSheet.UsedRange.Rows.Count).Row
                
                'Finds last row of Summary sheet
                LR = wkbDest.Sheets("Summary").UsedRange.Rows(wkbDest.Sheets("Summary").UsedRange.Rows.Count).Row
                
                'Copies range from source file to Summary sheet
                wkbSource.ActiveSheet.Range("A2:G" & currentLR).Copy Destination:=wkbDest.Sheets("Summary").Range("A" & LR + 1)
                
                'Loops through each range
                For j = 1 To 5
                
                    'Determines which sheet to paste in
                    If j = 1 Then
                        shtName = "Capital" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 2 Then
                        shtName = "Resources" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 3 Then
                        shtName = "Header3" 'Ensure sheet name matches sheet in the Summary workbook
                    ElseIf j = 4 Then
                        shtName = "Header4" 'Ensure sheet name matches sheet in the Summary workbook
                    Else
                        shtName = "Header5" 'Ensure sheet name matches sheet in the Summary workbook
                    End If
                    
                    'Finds last row of variable sheet
                    LR = wkbDest.Sheets(shtName).Range("A" & Rows.Count).End(xlUp).Row
                    
                    'Sets range according to variable sheet
                    Set rng = wkbSource.ActiveSheet.Range("A" & j & ":" & "G" & j)
                    
                    'Determines which row to paste in
                    If wkbDest.Sheets(shtName).Range("A" & LR).Value = "" Then
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=wkbDest.Sheets(shtName).Range("A" & LR)
                    Else
                        'Copies range from source file to Summary workbook
                        rng.Copy Destination:=wkbDest.Sheets(shtName).Range("A" & LR + 1)
                    End If
                    
                Next j

            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    
    Application.ScreenUpdating = True
End Sub

Please let me know if this is what you needed.

Bill