none
VBA to Merge several Sheets into a Single Summary RRS feed

  • Question

  • There used to be a Excel forum for help with VBA/Macro's that was very helpful.  I apologise in advance if I'm in the wrong place.  If so I would appreciate being pointed in the right direction.

    I have budgeting workbooks that can have in excess of 100 sheets. There are 16 Divisional budget files.

    I need to create a summary sheet that adds a range of rows and columns data from each sheet to a single sheet for upload to Oracle using a set template for each Division. Column A data is fixed and the same for each budget A4:A15 &  A17:A40. (there is a subtotal to skip at A16). These are fixed account numbers and are in the Parameters sheet. The corresponding expenditure data is columns AJ to AU (months) with the same row range in each Budget Sheet.

    I need to create a summary sheet containing the data from each sheet between Sheets "Start" and "End" added one on top of the other.

    The target Upload summary sheet:

    Starting at:

    C10 =Budget Year 2019. Always the same and is contained in the parameters sheet in the budget file at B2.

    D10= "030" (fixed length) leading zero essential. On the parameters sheet at C2 but always fixed for each budget entity.

    E10=Cost Centre Number from each budget sheet at A1. All will have leading zero (EG 0301001 fixed length) that is essential

    F10=Account Number and may have leading zeros (EG 041100 fixed length)

    G10 = "001" (fixed length) leading zero essential. On the parameters sheet at D2 but always fixed for each budget entity.

    H10:S10 = Monthly Budget data from sheets

    There is a check total for Cols H to S.  Col B has "Totals:" on this row.

    I have more than 550 cost centres and 45 accounts so do this manually would take an age and my VBA skills are rudimentary but I can follow and modify the code.  I will repeat the process for revenue accounts, (a smaller list) and should be able to modify the ranges to suit but the data will need to be converted from negative to positive for the upload.

    Cheers Jim

    Share sample files on OneDirve: I've had to remove the links until the Onedrive account is verified.

    https://1drv.ms/x/s!AhrEi5w1qOcdc__aeXEzsSDnG_U

    https://1drv.ms/x/s!AhrEi5w1qOcdcMeyyWIUF_KpXDg



    Thursday, June 14, 2018 12:41 AM

Answers

  • Hello Jim,

    Please check if below code could work for you. 

    Sub Combine() ' test looping through start to ending sheets
        Application.EnableCancelKey = xlDisabled
        Application.ScreenUpdating = False
        Dim wks As Worksheet
        Dim i As Integer
        Dim iStart As Integer
        Dim iEnd As Integer
        Dim UploadSheet As Worksheet
        On Error Resume Next
        If Evaluate("ISREF('Upload'!A1)") Then
        Set UploadSheet = Worksheets("Upload")
        Else
        MsgBox "WorkSheet Upload does not exist"
        Exit Sub
        End If
        
        iStart = GetStartIndex()
        iEnd = GetEndIndex()
        LastRowIndex = UploadSheet.Cells(UploadSheet.Rows.Count, 3).End(xlUp).Row
        UploadSheet.Rows("3:" & LastRowIndex).Delete
        STARTTIME = Now
        UploadSheetRowCount = 3
        PeriodYear = Worksheets("Parameters").Range("D2")
        ENTITY = Worksheets("Parameters").Range("E2")
        FUND = Worksheets("Parameters").Range("F2")
        If iStart > 0 And iEnd > 0 And iEnd > iStart Then
                For i = iStart To iEnd
    '            For i = 8 To 8
                Set wks = ThisWorkbook.Worksheets(i)
                COSTCENTRE = "'" & ENTITY & wks.Name
                'PeriodYear
                UploadSheet.Cells(UploadSheetRowCount, 3) = PeriodYear
                'ENTITY
                UploadSheet.Cells(UploadSheetRowCount, 4) = ENTITY
                'FUND
                UploadSheet.Cells(UploadSheetRowCount, 7) = FUND
                'COST CENTRE
                UploadSheet.Cells(UploadSheetRowCount, 5) = COSTCENTRE
                StartRowIndex = UploadSheetRowCount
    
                UploadSheet.Range("H" & StartRowIndex).Formula = "='" & wks.Name & "'!AJ4"
                UploadSheet.Range("H" & StartRowIndex).AutoFill UploadSheet.Range("H" & StartRowIndex & ":S" & StartRowIndex)
                UploadSheet.Range("H" & StartRowIndex & ":S" & (StartRowIndex + 11)).FillDown
                
                UploadSheet.Range("H" & (StartRowIndex + 12)).Formula = "='" & wks.Name & "'!AJ17"
                UploadSheet.Range("H" & (StartRowIndex + 12)).AutoFill UploadSheet.Range("H" & (StartRowIndex + 12) & ":S" & (StartRowIndex + 12))
                UploadSheet.Range("H" & (StartRowIndex + 12) & ":S" & (StartRowIndex + 12 + 24)).FillDown
                
                
                    For j = 4 To 40
                    If j <> 16 Then
                    BudgetName = wks.Cells(j, 1).Text
                    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 1)
                    'ACCOUNT
                     UploadSheet.Cells(UploadSheetRowCount, 6) = Account
                     UploadSheetRowCount = UploadSheetRowCount + 1
                    End If
                    EndRowIndex = UploadSheetRowCount - 1
                    Next j
                UploadSheet.Range("C" & StartRowIndex & ":C" & EndRowIndex).FillDown
                UploadSheet.Range("D" & StartRowIndex & ":D" & EndRowIndex).FillDown
                UploadSheet.Range("E" & StartRowIndex & ":E" & EndRowIndex).FillDown
                UploadSheet.Range("G" & StartRowIndex & ":G" & EndRowIndex).FillDown
            Next i
        End If
        Debug.Print DateDiff("s", STARTTIME, Now)
    Application.ScreenUpdating = True
    End Sub
    
    
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Proposed as answer by Terry Xu - MSFT Friday, June 22, 2018 8:14 AM
    • Marked as answer by Jim from Oz Friday, June 22, 2018 8:38 AM
    Thursday, June 21, 2018 10:01 AM

All replies

  • Hi Jim,

    It seems that you are looking for some VBA codes for your requirement. To get more suggestion, I would move the thread to Excel for developers forum for more help.

    Thanks for the understanding.


    Best Regards,
    Winnie Liang


    Please remember to mark the replies as answers if they helped. If you have feedback for TechNet Subscriber Support, contact tnsf@microsoft.com.


    Click here to learn more. Visit the dedicated forum to share, explore and talk to experts about Microsoft Teams.

    Thursday, June 14, 2018 8:26 AM
  • Hi Winnie,

    Thanks for the advice.  I'm still trying to familiarise myself with the process of navigating the site.  It's much larger than the version I used around 2007-8.

    You are correct, I'm looking for code that merges all of these cost centres as efficiently as possible keeping in mind there will probably be several iterations before the budget is final.  I'm in a busy teaching hospital and the current process consumes hundreds of man hours when it should only be a few.  If you could advise me how I move this to the correct forum I would be much appreciative.

    BTW: I would not have seen your reply had I not edited the question.  I'm in Oz so I thought that was the problem (time difference). I'm now very relieved there is some kind souls watching.

    Cheers

    Jim


    • Edited by Jim from Oz Thursday, June 14, 2018 11:15 PM omission
    Thursday, June 14, 2018 11:07 PM
  • Hello Jim,

    I would suggest you share a simple workbook with some simple and not sensitive data so we could be better to understand your design and test our code.

    For sharing a document, you could share it via Cloud Storage, such as One Drive, and then put the link address here.

    Thanks for understanding,

    Best Regards,

    Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, June 15, 2018 8:58 AM
  • I'm on a government network so can't install the Onedrive app.

    I installed it on my tablet thinking I could email myself the sample files and upload them only to be advised my account is locked/blocked even though this is the first time I've accessed the Ondedrive account.

    I'm not sure where to go from here.  I have code that I'm creating that is a mismatch of recorded code and snippets from the net but it's cumbersome and will no doubt not be very efficient. Is there another way to get the files uploaded or attached?

    I'm mostly stuck on the loop procedure. Sr maybe some code to loop through the sheets between the START and END sheets might help.

    Cheers

    Jim

    Monday, June 18, 2018 12:07 AM
  • I've managed to un-block the OneDrive account but this account still says it's not verified.  I've removed the links.  Are you still able to access the location on Onedrive from this?

    https://1drv.ms/x/s!AhrEi5w1qOcdc__aeXEzsSDnG_U

    https://1drv.ms/x/s!AhrEi5w1qOcdcMeyyWIUF_KpXDg

    Otherwise I'm stuck. I've tried logging off and on but to no avail.

    Cheers

    Jim

    Monday, June 18, 2018 2:14 AM
  • Hello Jim in Oz,

    I have successfully download these files. I'm checking them and i think i will take some time to do this work. Your patience will be greatly appreciated.

    Thanks for understanding.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, June 19, 2018 9:01 AM
  • Hello Jim,

    I could see that you copy title from WorkSheets(2). However, I don't get to know where the sheet is. There is no sheet has a title row as you show in "Upload" sheet. I renamed your "Upload" sheet as "UploadTest" sheet for copying title row and then try to generate a new "Upload" sheet.

    Besides, the Budget Parameters name are different in Parameters Sheet and data sheet(1057,1140....). For instance, in the data sheet, it is "AA3050 - Nursing Salaries" and in Parameters sheet, it is "AA3050- Nursing Salaries". It missed a space character in front of "-". I would suggest you update to keep them consistent.

    See the sample code.

    Sub Combine() ' test looping through start to ending sheets
        Application.ScreenUpdating = False
        Dim wks As Worksheet
        Dim i As Integer
        Dim iStart As Integer
        Dim iEnd As Integer
        Dim UploadSheet As Worksheet
        On Error Resume Next
        If Evaluate("ISREF('Upload'!A1)") Then
        Set UploadSheet = Worksheets("Upload")
        Else
        Set UploadSheet = Worksheets.Add(Sheets("Toc"))
        UploadSheet.Name = "Upload"
        End If
              
        iStart = GetStartIndex()
        iEnd = GetEndIndex()
    
        ' copy headings
        Sheets("UploadTest").Range("B2:S2").Copy Destination:=UploadSheet.Range("A1")
        UploadSheetRowCount = 1
        If iStart > 0 And iEnd > 0 And iEnd > iStart Then
    '        For i = iStart To iEnd
                For i = 8 To 8
                Set wks = ThisWorkbook.Worksheets(i)
                For j = 4 To 40
                If j <> 16 Then
                UploadSheetRowCount = UploadSheetRowCount + 1
                'Period Year
                UploadSheet.Cells(UploadSheetRowCount, 2).Formula = "=Parameters!$D$2"
                'ENTITY
                UploadSheet.Cells(UploadSheetRowCount, 3).Formula = "=Parameters!$E$2"
                'FUND
                UploadSheet.Cells(UploadSheetRowCount, 6).Formula = "=Parameters!$F$2"
                'COST CENTRE
                UploadSheet.Cells(UploadSheetRowCount, 4) = "'" & UploadSheet.Cells(UploadSheetRowCount, 3) & wks.Name
                'ACCOUNT
                BudgetName = wks.Cells(j, 1).Text
                UploadSheet.Cells(UploadSheetRowCount, 5) = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 1)
                'Jul-17->Jun-18
                    For k = 36 To 47
                        UploadSheet.Cells(UploadSheetRowCount, k - 36 + 7) = wks.Cells(j, k)
                    Next k
                End If
                Next j
            Next i
        End If
    Application.ScreenUpdating = True
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, June 20, 2018 6:10 AM
  • Thanks Terry,

    Sorry, I probably confused you with the remnant of code that I left in the file.  I never proceeded with this so none of the references will be correct. For example the reference to sheet TOC was from the code that loops through all sheets to create the Table of Contents ("TOC"). This remnant was the start of my attempt to adapt it to the upload data summary process.

    I inherited the workbook so the design isn't mine and also noticed the inconsistency with the descriptions.  This was a legacy from concatenating account level description from Oracle without checking.  I don't use these descriptions other than for information to the users.  Only the Account numbers mapped to the description is important for the upload. I can see because of this only one account is copied (the only matching description).  Fixing this fixed the issue.  Would you have a quick piece of code to remove this first space? It could save me a lot of time updating all models.

    The headings on row 2  in the Upload Sheet won't change so the process should start from row 3.  It currently over writes row 2 where the fixed headings are located. The total for each column is not necessary other than as a check of the total workbook. Once it's checked The contents of the upload sheet in the budget are copied to the actual Oracle Upload template.

    You code refers to UploadTest which I assume is something you created.

    I'll uploaded the file again to show the code for the table of contents just so you can see where I started. The result looks very promising so thank you again for your solution.  You will have saved many people a lot of time.


    https://1drv.ms/x/s!AhrEi5w1qOcddDkf8vpOtA1qAmw
    • Edited by Jim from Oz Thursday, June 21, 2018 1:04 AM Add file link
    Thursday, June 21, 2018 1:03 AM
  • Hello Jim,

    Please check if below code could work for you. 

    Sub Combine() ' test looping through start to ending sheets
        Application.EnableCancelKey = xlDisabled
        Application.ScreenUpdating = False
        Dim wks As Worksheet
        Dim i As Integer
        Dim iStart As Integer
        Dim iEnd As Integer
        Dim UploadSheet As Worksheet
        On Error Resume Next
        If Evaluate("ISREF('Upload'!A1)") Then
        Set UploadSheet = Worksheets("Upload")
        Else
        MsgBox "WorkSheet Upload does not exist"
        Exit Sub
        End If
        
        iStart = GetStartIndex()
        iEnd = GetEndIndex()
        LastRowIndex = UploadSheet.Cells(UploadSheet.Rows.Count, 3).End(xlUp).Row
        UploadSheet.Rows("3:" & LastRowIndex).Delete
        STARTTIME = Now
        UploadSheetRowCount = 3
        PeriodYear = Worksheets("Parameters").Range("D2")
        ENTITY = Worksheets("Parameters").Range("E2")
        FUND = Worksheets("Parameters").Range("F2")
        If iStart > 0 And iEnd > 0 And iEnd > iStart Then
                For i = iStart To iEnd
    '            For i = 8 To 8
                Set wks = ThisWorkbook.Worksheets(i)
                COSTCENTRE = "'" & ENTITY & wks.Name
                'PeriodYear
                UploadSheet.Cells(UploadSheetRowCount, 3) = PeriodYear
                'ENTITY
                UploadSheet.Cells(UploadSheetRowCount, 4) = ENTITY
                'FUND
                UploadSheet.Cells(UploadSheetRowCount, 7) = FUND
                'COST CENTRE
                UploadSheet.Cells(UploadSheetRowCount, 5) = COSTCENTRE
                StartRowIndex = UploadSheetRowCount
    
                UploadSheet.Range("H" & StartRowIndex).Formula = "='" & wks.Name & "'!AJ4"
                UploadSheet.Range("H" & StartRowIndex).AutoFill UploadSheet.Range("H" & StartRowIndex & ":S" & StartRowIndex)
                UploadSheet.Range("H" & StartRowIndex & ":S" & (StartRowIndex + 11)).FillDown
                
                UploadSheet.Range("H" & (StartRowIndex + 12)).Formula = "='" & wks.Name & "'!AJ17"
                UploadSheet.Range("H" & (StartRowIndex + 12)).AutoFill UploadSheet.Range("H" & (StartRowIndex + 12) & ":S" & (StartRowIndex + 12))
                UploadSheet.Range("H" & (StartRowIndex + 12) & ":S" & (StartRowIndex + 12 + 24)).FillDown
                
                
                    For j = 4 To 40
                    If j <> 16 Then
                    BudgetName = wks.Cells(j, 1).Text
                    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 1)
                    'ACCOUNT
                     UploadSheet.Cells(UploadSheetRowCount, 6) = Account
                     UploadSheetRowCount = UploadSheetRowCount + 1
                    End If
                    EndRowIndex = UploadSheetRowCount - 1
                    Next j
                UploadSheet.Range("C" & StartRowIndex & ":C" & EndRowIndex).FillDown
                UploadSheet.Range("D" & StartRowIndex & ":D" & EndRowIndex).FillDown
                UploadSheet.Range("E" & StartRowIndex & ":E" & EndRowIndex).FillDown
                UploadSheet.Range("G" & StartRowIndex & ":G" & EndRowIndex).FillDown
            Next i
        End If
        Debug.Print DateDiff("s", STARTTIME, Now)
    Application.ScreenUpdating = True
    End Sub
    
    
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Proposed as answer by Terry Xu - MSFT Friday, June 22, 2018 8:14 AM
    • Marked as answer by Jim from Oz Friday, June 22, 2018 8:38 AM
    Thursday, June 21, 2018 10:01 AM
  • Hi Terry,

    This works brilliantly except that the Account, Fund and Entity need to keep the leading zeros. Not every account has a leading zero.

    Should I submit a new question to remove the first space from the description on each sheet in the range START to END?

    Thanks Jim

    EDIT:

    I've managed to amend the Entity and Fund which solved the leading zeros. Happy for you to change this if you have a more efficient way.

    But I can't see an easy amendment for the occasional Account with leading zeros.

     Entity = "'" & Worksheets("Parameters").Range("E2")
        FUND = "'" & Worksheets("Parameters").Range("F2")
        If iStart > 0 And iEnd > 0 And iEnd > iStart Then
                For i = iStart To iEnd
    '            For i = 8 To 8
                Set wks = ThisWorkbook.Worksheets(i)
                COSTCENTRE = Entity & wks.Name
                'PeriodYear 

    • Edited by Jim from Oz Friday, June 22, 2018 12:02 AM Add Code edit sample
    Thursday, June 21, 2018 11:48 PM
  • Hi Terry,

    I also forgot to mention that the budget values for each month need to be to two decimal places only. Otherwise I have rounding issues on reconciliation.

    EDIT: It would suit better if the budget cells have a value only just to make the transfer to the actual Upload file a little less error prone for the users.

    An interesting aside: as I was trying to format the Account code for the leading zeros I noticed that if I preformat the column to Special>Chinese characters!

    Cheers

    Jim


    • Edited by Jim from Oz Friday, June 22, 2018 2:18 AM Edit value format
    Friday, June 22, 2018 1:16 AM
  • Hello Jim in Oz,

    >>Should I submit a new question to remove the first space from the description on each sheet in the range START to END?

    Yes. I would suggest you post a new thread and detail your issue.

    >>But I can't see an easy amendment for the occasional Account with leading zeros.

     You could try code like

                    BudgetName = wks.Cells(j, 1).Text
                    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 1).Text
                    UploadSheet.Cells(UploadSheetRowCount, 6) = "'" & Account

    >>I also forgot to mention that the budget values for each month need to be to two decimal places only. Otherwise I have rounding issues on reconciliation.

    Please post a new thread for the issue too.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Friday, June 22, 2018 6:54 AM
  • Thanks Terry,

    As mentioned changing the column format to Special>Chinese seemed to have fixed the leading zero issue.

    The upload data creation works really well other than adding an additional line when the last Cost Centre sheet is complete.  If it's not a simple fix I can always add code to delete the final line.

    You have been of tremendous help which is very much appreciated....I wish I had half your talent with coding...but thanks to you I've learned a lot.

    I will submit a new question for the space removal issue.

    Cheers

    Jim

    Friday, June 22, 2018 8:10 AM
  • Hello Jim,

    I'm glad to hear that it could be helpful. It seems your original issue has been resolved. I would suggest you mark the helpful reply as answer which is the correct way to close a thread.

    For your other issue, please feel free to post thread to let us know.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, June 22, 2018 8:14 AM
  • Hi Terry,

    This has been extremely useful thank you again.

    I wanted to adapt the code for another purpose. 

    I want to use it to create a database for movements in monthly forecasts by adding the data in each worksheet to a master table where I can track each previous month to the latest forecast. To do so I need to change the non-contiguous ranges to include rows 43:44, rows 46:53 and rows 59:69.

    I've tried the trial and error approach but get a bit lost with the multiple ranges (UploadSheet.Range).

    I also wanted to change 'Fund' to a date but the code fails when I change all instances of Fund to 'Month' unless I only change the entry at FUND = "'" & Worksheets("Parameters").Range("F2") to a date on the worksheet and leave the definition as 'Fund'.  It would help if I could lose the "'" apostrophe [EDIT: removed"'" & and it seemed to do the trick].

    I only need to pick up the higher level account so I changed:

    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 1)

    TO

    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 2).

    it works so hopefully it is the correct amendment.

    I'd be grateful for any help you can offer.

    Cheers

    Jim


    • Edited by Jim from Oz Monday, August 27, 2018 8:46 AM marked a question as solved
    Monday, August 27, 2018 8:17 AM