VBA to update Actuals & Forecast

[rahildhody]

Hi,

Im trying to copy the formula from one cell to another as the date of the actual month changes.

As the date changes to 31/5/24 in AD5, i want to copy the formula from Apr24 to May24 & do that for each of the 3 blocks shown.

It seems simple enough code to do for 5-10 of these blocks, but i have around 200 blocks going down the page. I thought of using a For loop with intersect wherever the cell = 2024P4, but because the sheet is so long (over 15,000 rows) it takes a really long time.

idea is to copy AG10277, paste in AH10277, then copy AG10286, paste in AH10286, then copy AG10295, paste in AG10295.

if there a neater code that can run quickly for over 15,000 rows & copy formula from Apr24 to May24 (in this example) using a VBA code?

Any help would be much appreciated.

Regards
Rahil

 

[rahildhody]

Ive tried to write a code but it continues to loop through the data & doesnt stop.

Sub FindInstancesAndAddresses()
    Dim CurrentMonth As Range, CurrentYear As Range, NextYear As Range, NextMonth As Range
    Dim ws As Worksheet
    Dim searchRange1 As Range
    Dim searchRange2 As Range
    Dim cellCYear As Range, cellNYear As Range, cellCMonth As Range, cellNMonth
    Dim CYearRow As Integer, NYearRow As Integer, CMonthCol As Integer, NMonthCol As Integer
    
    Set CurrentYear = Sheets("Input Template").Range("AD4")
    Set CurrentMonth = Sheets("Input Template").Range("AD5")
    Set NextYear = Sheets("Input Template").Range("AE4")
    Set NextMonth = Sheets("Input Template").Range("AE5")
    
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Input Template") ' Change "Sheet1" to your sheet name
    
    ' Set the search ranges
    Set searchRange1 = ws.Range("AA1:AA20000")
    Set searchRange2 = ws.Range("AD6:AO6")
    
    For Each cellCMonth In searchRange2
        If cellCMonth.Value = CurrentMonth Then
            CMonthCol = cellCMonth.Column
        End If
    Next
    
    For Each cellNMonth In searchRange2
        If cellNMonth.Value = NextMonth Then
            NMonthCol = cellNMonth.Column
        End If
    Next
        
    For Each cellCYear In searchRange1
        If cellCYear.Value = CurrentYear Then
            CYearRow = cellCYear.Row
                ws.Cells(CYearRow, CMonthCol).Copy
            
                For Each cellNYear In searchRange1
                    If cellNYear.Value = NextYear Then
                        NYearRow = cellNYear.Row
                    ws.Cells(NYearRow, NMonthCol).PasteSpecial xlPasteFormulas
                
                ws.Cells(CYearRow, CMonthCol).Copy
                ws.Cells(NYearRow, NMonthCol).PasteSpecial xlPasteFormats
                
                End If
                Next cellNYear
                
        End If
    Next cellCYear
    
End Sub

Hoping for an easier way to execute this code without the model breaking.

Any help would be truly appreciated.

Regards
Rahil

 

[Snakehips]

@rahildhody Your two posts appear to contradict slightly. Apologies if I have misinterpreted or over simplified.
If not then I have assumed the following:
Current date is in AA3
P1 to P12 in AD6:AO6 are month periods in form of a date. Thus can be tested to yield a month of between 1 - 12
The code is to extend the current month code to the next month's column. Or if is a new year then down to P1 of the next year.
Any given year will repeat every 9 rows.

Test the below on a backed up copy.

Sub FindInstancesAndAddresses()
    
    Dim ws As Worksheet
    Dim Col As Integer
    Dim Yr As Long
    Dim Yrw As Long
    Dim lr As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Input Template") ' Change "Sheet1" to your sheet name
    
   With ws
        Col = Month(.Range("AD3")) + 29
        Yr = Year(.Range("AD3"))
        Yrw = Application.WorksheetFunction.Match(Yr, .Range("AA1:AA20000"), 0)
        lr = .Range("AA" & Rows.Count).End(xlUp).Row
        
        Do While Yrw <= lr
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            If Col = 41 Then
            .Cells(Yrw, 30).AutoFill Destination:=.Range(.Cells(Yrw, 30), .Cells(Yrw + 1, 30)), Type:=xlFillDefault
            Else
             .Cells(Yrw, Col).AutoFill Destination:=.Range(.Cells(Yrw, Col), .Cells(Yrw, Col + 1)), Type:=xlFillDefault
            End If
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True
            
            Yrw = Yrw + 9
        Loop
    End With
    
End Sub

HTH

 

[rahildhody]

Hi @Snakehips

Thank you for taking the time out to write up that code. It mostly does what I intend it to do, but the issue is that the next year block might not always be 9rows below. it could be more as i have headings in between various blocks.

Ive managed to write up a code using autofilter & it works well & solves the 95% of the issue. the code still individually copies each formula & pastes it for every single row. I'm hoping for a more optimised solution that carries out the code a little faster as it individually goes through over 10000 rows to copy/paste the data & im having to wait atleast 3-5mins for it to go through the code.

Sub CopyCurrentToNextMonthYearForAllInstances4()
    Dim ws As Worksheet
    Dim CurrentMonth As String, CurrentYear As String
    Dim NextMonth As String, NextYear As String
    Dim CMonthCol As Long, NMonthCol As Long
    Dim filterRange As Range
    Dim dataRange As Range
    Dim currentCell As Range
    Dim pasteRange As Range
    Dim lastRow As Long
    Dim pasteCell As Range
    Dim nextYearRow As Long

    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Input Template") ' Change "Input Template" to your sheet name

    ' Set the values for current and next month/year
    CurrentMonth = ws.Range("AD5").Value
    CurrentYear = ws.Range("AD4").Value
    NextMonth = ws.Range("AE5").Value
    NextYear = ws.Range("AE4").Value

    ' Find the column for the current month and next month
    CMonthCol = Application.Match(CurrentMonth, ws.Range("A6:AZ6"), 0)
    NMonthCol = Application.Match(NextMonth, ws.Range("A6:AZ6"), 0)

    ' Find the last row in column AA
    lastRow = ws.Cells(ws.Rows.Count, "AA").End(xlUp).Row

    ' Filter rows containing the current year in column AA
    With ws
        .AutoFilterMode = False ' Remove any existing filters
        .Range("AA1:AA" & lastRow).AutoFilter Field:=1, Criteria1:=CurrentYear
        ' Exclude header row
        Set filterRange = .Range("AA2:AA" & lastRow).SpecialCells(xlCellTypeVisible)
        ' Check if the next year is different from the current year
        If NextYear <> CurrentYear Then
            .Range("AA1:AA" & lastRow).AutoFilter Field:=1, Criteria1:=NextYear
            Set filterRange = Union(filterRange, .Range("AA2:AA" & lastRow).SpecialCells(xlCellTypeVisible))
        End If
    End With

    If Not filterRange Is Nothing Then
        ' Loop through each visible cell in the filtered range
        For Each currentCell In filterRange.Cells
            ' Define the range to copy (current month cell)
            Set dataRange = ws.Cells(currentCell.Row, CMonthCol)
            ' Define the range to paste (next month cell)
            If CurrentMonth = "P12" Then
                ' If current month is P12, adjust the row and next month column
                nextYearRow = ws.Columns("AA").Find(What:=NextYear, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Row
                NMonthCol = Application.Match("P1", ws.Range("A6:AZ6"), 0)
                Set pasteCell = ws.Cells(nextYearRow, NMonthCol).Offset(currentCell.Row - filterRange.Cells(1).Row)
            Else
                ' If current month is not P12, keep the row and next month column
                Set pasteCell = ws.Cells(currentCell.Row, NMonthCol)
            End If
            ' Copy the formula from current month cell
            dataRange.Copy
            ' Paste the formula to next month cell
            pasteCell.PasteSpecial Paste:=xlPasteFormulas
            ' Paste the formatting to next month cell
            pasteCell.PasteSpecial Paste:=xlPasteFormats
            
            Application.CutCopyMode = False
        Next currentCell
    End If

    ' Turn off AutoFilter
    ws.AutoFilterMode = False

    ' Notify user
    MsgBox "Formulas and formatting copied successfully."
End Sub

Is there a more optimised solution than this?


Regards,
Rahil

 

[rahildhody]

This is what the sheet looks like & the Heading 1, Heading 2 (& sometimes Heading 3) are at various intersections. There's no set length/# of rows inbetween years unfortunately.

 

[rahildhody]

@Snakehips

sorry for bombading, but think i've managed to use arrays to solve my issue.

But it does something funky when i run the code over 10000 rows for the case where Current Month = P12 & Next Month = P1. (it works great for all other cases)

Could someone assist with why that is? the processing time for the case where Current Month = P12 & Next Month = P1 is longer.

Sub UpdateActuals()
    Dim ws As Worksheet
    Dim CurrentMonth As String, CurrentYear As String
    Dim NextMonth As String, NextYear As String
    Dim CMonthCol As Long, NMonthCol As Long
    Dim lastRow As Long
    Dim currentCell As Range
    Dim nextYearRow As Long
    Dim filteredData() As Long
    Dim i As Long, count As Long
    Dim pasteCell As Range

    ' Set the worksheet
    Set ws = ActiveSheet
   
    ' Set the values for current and next month/year
    CurrentMonth = ws.Range("AD5").Value
    CurrentYear = ws.Range("AD4").Value
    NextMonth = ws.Range("AE5").Value
    NextYear = ws.Range("AE4").Value

    ' Find the column for the current month and next month
    CMonthCol = Application.Match(CurrentMonth, ws.Range("A6:AZ6"), 0)
    NMonthCol = Application.Match(NextMonth, ws.Range("A6:AZ6"), 0)

    ' Find the last row in column AA
    lastRow = ws.Cells(ws.Rows.count, "AA").End(xlUp).Row

    ' Turn off screen updating and automatic calculations to speed up the macro
    'Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Filter rows containing the current year in column AA
    With ws
        .AutoFilterMode = False ' Remove any existing filters
        .Range("AA1:AA" & lastRow).AutoFilter Field:=1, Criteria1:=CurrentYear
        ' Collect the visible rows into an array
        count = 0
        On Error Resume Next
        For Each currentCell In .Range("AA2:AA" & lastRow).SpecialCells(xlCellTypeVisible)
            count = count + 1
            ReDim Preserve filteredData(1 To count)
            filteredData(count) = currentCell.Row
        Next currentCell
        On Error GoTo 0

        ' Check if the next year is different from the current year and add those rows to the array
        If NextYear <> CurrentYear Then
            .AutoFilterMode = False
            .Range("AA1:AA" & lastRow).AutoFilter Field:=1, Criteria1:=NextYear
            On Error Resume Next
            For Each currentCell In .Range("AA2:AA" & lastRow).SpecialCells(xlCellTypeVisible)
                count = count + 1
                ReDim Preserve filteredData(1 To count)
                filteredData(count) = currentCell.Row
            Next currentCell
            On Error GoTo 0
        End If
    End With

    ' Process the filtered data
    If count > 0 Then
        For i = 1 To UBound(filteredData)
            ' Define the range to copy (current month cell)
            Set dataRange = ws.Cells(filteredData(i), CMonthCol)

            ' Define the range to paste (next month cell)
            If CurrentMonth = "P12" Then
                ' If current month is P12, adjust the row and next month column
                nextYearRow = Application.Match(CLng(NextYear), ws.Range("AA1:AA" & lastRow), 0)
                NMonthCol = Application.Match("P1", ws.Range("A6:AZ6"), 0)
                Set pasteCell = ws.Cells(nextYearRow, NMonthCol).Offset(filteredData(i) - filteredData(1))
            Else
                ' If current month is not P12, keep the row and next month column
                Set pasteCell = ws.Cells(filteredData(i), NMonthCol)
            End If

            ' Copy the formula from current month cell
            dataRange.Copy

            ' Paste the formula to next month cell
            pasteCell.PasteSpecial Paste:=xlPasteFormulas

            ' Paste the formatting to next month cell
            pasteCell.PasteSpecial Paste:=xlPasteFormats

            Application.CutCopyMode = False
        Next i
    End If

    ' Turn off AutoFilter
    ws.AutoFilterMode = False

    ' Restore screen updating and automatic calculations
    'Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ' Notify user
    MsgBox "Formulas and formatting copied successfully."
End Sub