none
Edit VBA Code to Select non-contiguous ranges RRS feed

  • Question

  • Terry XU very kindly provided code to merge several sheets into a single summary sheet for upload to a budget file.

    Now I want to adapt the code for another purpose. I've saved a sample copy with the current code in one drive: Hopefully this is accessible.  If not I can put the entire code here.

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

    I want amend the code 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. This si the section of code I need to extend:

    UploadSheet.Range("H" & startrowindex).Formula = "=round('" & wks.Name & "'!P4,2)"
                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 = "=round('" & wks.Name & "'!P17,2)"
                UploadSheet.Range("H" & (startrowindex + 12)).AutoFill UploadSheet.Range("H" & (startrowindex + 12) & ":S" & (startrowindex + 12))
                UploadSheet.Range("H" & (startrowindex + 12) & ":S" & (startrowindex + 12 + 25)).FillDown
             
             'add revenue rows 43 & 44 Col P to AA skipping row 41 & 42
             
             'add revenue rows 46 & 53 Col P to AA skipping row 45
             
             'add FTE rows 59 to 69 Col P to AA skipping rows 54 to 58
                       
               
                    For j = 4 To 40 'need to extend to row 69
                    If j <> 16 Then
                    BudgetName = wks.Cells(j, 1).Text
                    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 2)
                     UploadSheet.Cells(UploadSheetRowCount, 6) = Account
                     UploadSheetRowCount = UploadSheetRowCount + 1
                    End If
                    EndRowIndex = UploadSheetRowCount - 1
                                   
                    Next j

    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'. I remove the apostrophe from" FUND = "'" & Worksheets("Parameters").Range("F2")" to refer to a date on the parameters worksheet and leave the definition as 'Fund' and it works.  It would be nice to know why changing FUND to MONTH causes the code to fail.

    I now 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



    Wednesday, August 29, 2018 8:47 AM

Answers

  • Thanks to everyone who has considered this issue.

    The good news is, I've managed modified the code to pick up all of the account ranges rather than skip the totals.  It serves my purpose to create a database of forecasts and only adds a few thousand lines to my 30K lines per month.

    The better news is that I've learned a few things in the process.

    Cheers

    Jim

    • Marked as answer by Jim from Oz Friday, September 14, 2018 1:58 AM
    Friday, September 14, 2018 1:57 AM

All replies

  • Hi Jim,

    This forum focuses on general discussion for Excel. I notice your issue is related to Excel Macro codes. To better fix the issue, I would move the thread to Excel for developers forum for more help.

    Thanks for your 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, August 30, 2018 2:43 AM
  • Thanks Winnie,

    I did try to post it there but couldn't find it, but have to admit I am a novice at this.  Can you tell me which forum category Excel for Developers is in?

    Thanks again for your help, it's much appreciated.

    Jim

    Thursday, August 30, 2018 3:44 AM
  • Thanks Winnie,

    I did try to post it there but couldn't find it, but have to admit I am a novice at this.  Can you tell me which forum category Excel for Developers is in?

    Thanks again for your help, it's much appreciated.

    Jim


    I have moved the thread to correct forum :)

    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, August 30, 2018 6:03 AM
  • Hi Jim,

    I'm researching on this problem and will get back to you as soon as possible.

    Best Regards,

    Yuki


    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.

    Thursday, August 30, 2018 9:52 AM
    Moderator
  • I've added the whole of the code in case it helps.  I can manage to add the descriptions but can't realign the values from here: "For j = 4 To 40 'need to extend to row 69
                    If j <> 16 Then"

    Public Function GetStartIndex() As Integer
        On Error Resume Next
        GetStartIndex = ThisWorkbook.Worksheets("START").Index + 1
    End Function
    
    Public Function GetEndIndex() As Integer
        On Error Resume Next
        GetEndIndex = ThisWorkbook.Worksheets("END").Index - 1
    End Function
    
    
    Sub CombineUploadForecast() ' test looping through start to ending sheets
        
        
        Application.EnableCancelKey = xlDisabled
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
        
        Dim wks As Worksheet
        Dim i As Integer
        Dim iStart As Integer
        Dim iEnd As Integer
        Dim UploadSheet As Worksheet
        Dim Account As String
       ' Dim Fund As Date
        Dim LastRow As Long
        
        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
        Worksheets("Upload").Select
        
        iStart = GetStartIndex()
        iEnd = GetEndIndex()
        lastrowindex = UploadSheet.Cells(UploadSheet.Rows.Count, 3).End(xlUp).Row
        Debug.Print lastrowindex
        
        UploadSheet.Rows("3:" & lastrowindex).Delete
        starttime = Now
        Debug.Print starttime
        
        UploadSheetRowCount = 3
        PeriodYear = Worksheets("Parameters").Range("D2")
        Entity = "'" & Worksheets("Parameters").Range("E2")
        Fund = Worksheets("Parameters").Range("F2") 'Apostophe removed when changed to Month. Fund is proxy for Month on worksheet
        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
        Debug.Print startrowindex
        
                UploadSheet.Range("H" & startrowindex).Formula = "=round('" & wks.Name & "'!P4,2)"
                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 = "=round('" & wks.Name & "'!P17,2)"
                UploadSheet.Range("H" & (startrowindex + 12)).AutoFill UploadSheet.Range("H" & (startrowindex + 12) & ":S" & (startrowindex + 12))
                UploadSheet.Range("H" & (startrowindex + 12) & ":S" & (startrowindex + 12 + 25)).FillDown
             
             'add revenue rows 43 & 44 Col P to AA skipping row 41 & 42
             
             'add revenue rows 46 & 53 Col P to AA skipping row 45
             
             'add FTE rows 59 to 69 Col P to AA skipping rows 54 to 58
                       
               
                    For j = 4 To 40 'need to extend to row 69
                    If j <> 16 Then
                    BudgetName = wks.Cells(j, 1).Text
                    Account = Worksheets("Parameters").Cells(WorksheetFunction.Match(BudgetName, Worksheets("Parameters").Columns(2), 0), 2)
                     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)
        
        Sheets("UPLOAD").Activate
        
        With Sheets("UpLoad")
    '        .Range("A3").Activate
            'Columns("E:E").Select
            LastRow = Cells(Rows.Count, "C").End(xlUp).Row ' will give last row in Table column
             Range("H1").Formula = "=SUM(H3:H" & LastRow & ")" ' add sum range to column head
             Range("I1").Formula = "=SUM(I3:I" & LastRow & ")" ' add sum range to column head
             Range("J1").Formula = "=SUM(J3:J" & LastRow & ")" ' add sum range to column head
             Range("K1").Formula = "=SUM(K3:K" & LastRow & ")" ' add sum range to column head
             Range("L1").Formula = "=SUM(L3:L" & LastRow & ")" ' add sum range to column head
             Range("M1").Formula = "=SUM(M3:M" & LastRow & ")" ' add sum range to column head
             Range("N1").Formula = "=SUM(N3:N" & LastRow & ")" ' add sum range to column head
             Range("O1").Formula = "=SUM(O3:O" & LastRow & ")" ' add sum range to column head
             Range("P1").Formula = "=SUM(P3:P" & LastRow & ")" ' add sum range to column head
             Range("Q1").Formula = "=SUM(Q3:Q" & LastRow & ")" ' add sum range to column head
             Range("R1").Formula = "=SUM(R3:R" & LastRow & ")" ' add sum range to column head
             Range("S1").Formula = "=SUM(S3:S" & LastRow & ")" ' add sum range to column head
    'End With
     
     ' With Sheets("UpLoad")
       
        Application.CutCopyMode = False
        Range("b2").Select
        ActiveCell.FormulaR1C1 = "Upl"
        Range("C2").Select
        ActiveCell.FormulaR1C1 = "Period Year"
        Range("D2").Select
        ActiveCell.FormulaR1C1 = "ENTITY"
        Range("E2").Select
        ActiveCell.FormulaR1C1 = "COST CENTRE"
        Range("F2").Select
        ActiveCell.FormulaR1C1 = "ACCOUNT"
        Range("G2").Select
        ActiveCell.FormulaR1C1 = "MONTH"
        Range("H2").Select
        ActiveCell.FormulaR1C1 = "Jul-2018"
        Range("I2").Select
        ActiveCell.FormulaR1C1 = "Aug-2018"
        Range("J2").Select
        ActiveCell.FormulaR1C1 = "Sep-2018"
        Range("K2").Select
        ActiveCell.FormulaR1C1 = "Oct-2018"
        Range("L2").Select
        ActiveCell.FormulaR1C1 = "Nov-2018"
        Range("M2").Select
        ActiveCell.FormulaR1C1 = "Dec-2018"
        Range("N2").Select
        ActiveCell.FormulaR1C1 = "Jan-2019"
        Range("O2").Select
        ActiveCell.FormulaR1C1 = "Feb-2019"
        Range("P2").Select
        ActiveCell.FormulaR1C1 = "Mar-2019"
        Range("Q2").Select
        ActiveCell.FormulaR1C1 = "Apr-2019"
        Range("R2").Select
        ActiveCell.FormulaR1C1 = "May-2019"
        Range("S2").Select
        ActiveCell.FormulaR1C1 = "Jun-2019"
        Range("T2").Select
        ActiveCell.FormulaR1C1 = "Messages"
        Range("U2").Select
      End With
        Range("B2:U2").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark2
            .TintAndShade = -0.249977111117893
            .PatternTintAndShade = 0
        End With
        
      Debug.Print LastRow
         Rows(LastRow + 1).Select
            Debug.Print LastRow
        Selection.Delete Shift:=xlUp
        
        Range("H1:S1").Select
        Selection.NumberFormat = "_(* #,##0_);_(* (#,##0)" ';_(* ""-""??_);_(@_)"
        
        Columns("H:S").Select
        Columns("H:S").EntireColumn.AutoFit
    
    Range("V1").Select
        ActiveCell.FormulaR1C1 = _
            "=IF(ROUNDDOWN(SUM(R1C8:R1C19),2)=ROUNDDOWN(Total!R42C48,2),""BALANCED"",""ROUNDING ERROR"")"
    Range("t1").Select
        ActiveCell.FormulaR1C1 = "=SUM(R1C8:R1C19)-Total!R42C48"
        Selection.NumberFormat = "_-* #,##0.00_-;[Red]( #,##0.00_-);_-* ""-""_-;_-@_-"
        
    Application.ScreenUpdating = True
    
     Application.Calculation = xlAutomatic
     Columns("H:S").EntireColumn.AutoFit
     Range("G1").Select
      
      'OptimizeVBA False
     Application.DisplayStatusBar = True
     
    End Sub

     

    Wednesday, September 5, 2018 4:29 AM
  • Hi Jim,

    >> 'add revenue rows 43 & 44 Col P to AA skipping row 41 & 42
             
    >> 'add revenue rows 46 & 53 Col P to AA skipping row 45
             
    >> 'add FTE rows 59 to 69 Col P to AA skipping rows 54 to 58

    Base on your description, please try below code to see if it works for you:

    Sub pasteExcel2()
        Dim sht1 As Worksheet
        Dim sht2 As Worksheet 'not used!
        Dim src2Range As Range
        Dim dest2Range As Range
        Dim r 'to store the last row
        Dim c 'to store the last column
    
        Set sht1 = Sheets("Sheet1")
        Set sht2 = Sheets("Sheet2")
    
        sht1.Activate 'Just in case... but not necesary
    
        r = Range("A43:A44").End(xlDown).Row 'Get the last row from A1 to down
        c = Range("A43:A44").End(xlToRight).Column 'Get the last Column from A1 to right
        Set src2Range = Range(Cells(1, 1), Cells(r, c)) 'source from selected range
        Set dest2Range = Range(Cells(1, 1), Cells(r, c))
        sht2.Range(dest2Range.Address).Value = src2Range.Value 'the same range in the other sheet.
    End Sub
    

    Hopefully it helps you. Looking forward to hearing from you.

    Best Regards,

    Yuki


    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.

    Friday, September 7, 2018 2:06 AM
    Moderator
  • Hi Yuki,

    I don't quite follow how this fits into my macro to accommodate the non-contiguous data that I've tried to add to Terry's original solution.

    If you look at the sample file I uploaded to Onedrive the original code copies all data in each sheet from row 4 to row 40 skipping row 16.  This works okay for all of my expenditure lines.  However, I need to do the same to add the revenue/FTE lines starting at row 43 to 44, skipping the subtotal at row 45.  Then repeating this for rows 46 to 53 skipping subtotals and blank rows 54 to 58, then repeating for rows 59 to 69. The skipped rows are not required in my database.

    The only option would be for me to copy all lines to row 69 and ignore the blanks and totals in the data. Since the data file will be around 400k rows by year end, I was hoping to avoid this.  

    Thanks for your help.

    Wednesday, September 12, 2018 4:51 AM
  • Thanks to everyone who has considered this issue.

    The good news is, I've managed modified the code to pick up all of the account ranges rather than skip the totals.  It serves my purpose to create a database of forecasts and only adds a few thousand lines to my 30K lines per month.

    The better news is that I've learned a few things in the process.

    Cheers

    Jim

    • Marked as answer by Jim from Oz Friday, September 14, 2018 1:58 AM
    Friday, September 14, 2018 1:57 AM