Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.
Option Explicit
Private Sub Workbook_Open()
'Sheets("Splash").Select
Application.OnTime Now() + TimeSerial(0, 0, 1), "module1.ShowForm"
End Sub
'This starts the code to update the Scenario Sheet calculations
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub 'only works on single data entry
'use the following (code commented) if you want to restrict the sheets that are checked
'if Sh.Name = "this sheet" then
'If Sh.Name <> "other sheet" Then
If Sh.Name Like "*Scenario*" Then 'This identifies the source for input
On Error Resume Next
If Not Intersect(Target, Range("N3")) Is Nothing Then 'checking every sheet, or inside the if on specific sheets
If Err.Number <> 0 Then Exit Sub
Application.EnableEvents = False 'avoid infinite loop because the next line will trigger a change event
ThisWorkbook.Worksheets("Scenario1").Range("R3").Value = Range("N3").Value * Range("Q3") + Range("N10") 'puts the value in to another worksheet - you need to specify the name
Application.EnableEvents = True
End If
On Error GoTo 0
If Not Intersect(Target, Range("M:M")) Is Nothing Then
If Left(Target.Formula, 1) = "=" Then 'its a formula
Application.EnableEvents = False
Range("N" & Target.Row).Formula = Target.Formula
Range("N" & Target.Row).Value = Range("N" & Target.Row).Value
Range("ZZ" & Target.Row).Value = True 'set a flag to note the macro put this value here
Application.EnableEvents = True
End If
End If
If Not Intersect(Target, Range("N:N")) Is Nothing Then 'set flag so we know whether to evaluate the M formula in N column
Application.EnableEvents = False
If Range("N" & Target.Row).Value = vbNullString Then 'user cleared it out, reset the flage
If Left(Range("M" & Target.Row).Formula, 1) = "=" Then 'its a formula!
Range("N" & Target.Row).Formula = Range("M" & Target.Row).Formula
Range("N" & Target.Row).Value = Range("N" & Target.Row).Value
End If
Range("ZZ" & Target.Row).Value = True 'set a flag to note the macro put this value here
Else
Range("ZZ" & Target.Row).Value = False
End If
Application.EnableEvents = True
End If
' If Not Intersect(Target, Range("M:Q")) Is Nothing Then 'if any value changes in the range, update the Result
If Target.Row >= 3 And Not Intersect(Target, Range("M:Q")) Is Nothing Then 'if any value changes in the range, update the Result
Application.EnableEvents = False
'Formula in A1 notation is: =C10*(1+F10)^(VLOOKUP(D10,CA_Calc_Engine!$D$7:$F$15,3,0)*E10)
Range("R" & Target.Row).FormulaR1C1 = _
"=if(RC[-3]=""One Time"",RC[-4],if(RC[-4]=0,0,RC[-4]*(1+RC[-1])^(VLOOKUP(RC[-3],CA_Calc_Engine!R7C6:R15C8,3,0))*RC[-2]))"
'=IF(O5="One Time",N5,IF(N5=0,0,N5*(1+Q5)^(VLOOKUP(O5,CA_Calc_Engine!$F$7:$H$15,3,0))*P5))
' "if(RC[-2]<>0,(RC[-4]*(1+RC[-1])^(VLOOKUP(RC[-3],CA_Calc_Engine!R7C6:R15C8,3,0)*RC[-2]))RC[-2]),RC[-4])"
' "if(RC[-2]="",0,(RC[-4]*(1+RC[-1])^(VLOOKUP(RC[-3],CA_Calc_Engine!R7C6:R15C8,3,0)*RC[-2]))RC[-2]),RC[-4])"
'Range("G" & Target.Row).Value = Range("G" & Target.Row).Value 'if formula is correct, then uncomment this line to just paste the value
Application.EnableEvents = True
End If
Call CheckExpMonths(Target)
End If 'if you are using excluding logic with an if statement, above
End Sub
'New code to expand months
Private Sub CheckExpMonths(ByVal Target As Range)
Dim NoYears As Long
Dim rngClear As Range
Dim LastCol As Long
If Not Intersect(Target, Target.Worksheet.Range("AB3")) Is Nothing Then
Application.EnableEvents = False
LastCol = Cells(4, Columns.Count).End(xlToLeft).Column
Set rngClear = Range("AJ2", Cells(4, Columns.Count)).Resize(6)
rngClear.ClearContents
NoYears = Range("AB3")
If NoYears > 1 Then
With Range("AI2")
.Offset(0, 1).Resize(, NoYears - 1).FormulaR1C1 = "=DATE(YEAR(rc[-1]),MONTH(rc[-1])+1,DAY(rc[-1]))"
.Offset(0, 1).Resize(, NoYears - 1).Value = .Offset(0, 1).Resize(, NoYears - 1).Value
End With
End If
Range("AI3:AI4").Copy Range("AI3:AI4").Resize(, NoYears)
Application.EnableEvents = True
End If
End Sub
Sub ClearWorksheet()
Dim r As Range
For Each r In ActiveSheet.Range("C3:Z5")
'UsedRange
If Not r.Locked Then
r.MergeArea.ClearContents
'r.ClearContents
End If
Next r
End Sub
Private Sub CheckExpMonths(ByVal Target As Range)
Dim numPeriods As Long
Dim rngClear As Range
Dim LastCol As Long
If Not Intersect(Target, Range("AB3")) Is Nothing Then
Application.EnableEvents = False
LastCol = Cells(4, Columns.Count).End(xlToLeft).Column
Set rngClear = Range("AJ2", Cells(4, Columns.Count)).Resize(6)
rngClear.ClearContents
numPeriods = Range("AB3")
If numPeriods > 1 Then
With Range("AI2")
.Resize(, numPeriods).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlMonth, Step:=1, Trend:=False
End With
End If
Range("AI3:AI4").Copy Range("AI3:AI4").Resize(, numPeriods)
Application.EnableEvents = True
End If
End Sub
Private Sub CheckExpMonths(ByVal Target As Range)
Dim numPeriods As Long
Dim rngClear As Range
Dim LastCol As Long
If Not Intersect(Target, Range("AB3")) Is Nothing Then
Application.EnableEvents = False
LastCol = Cells(4, Columns.Count).End(xlToLeft).Column
Set rngClear = Range("AJ2", Cells(4, Columns.Count)).Resize(6)
rngClear.ClearContents
numPeriods = Range("AB3")
If numPeriods > 1 Then
With Range("AI2")
.Resize(, numPeriods).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlMonth, Step:=1, Trend:=False
End With
Range("AI3:AI4").Copy Range("AI3:AI4").Resize(, numPeriods)
End If
Application.EnableEvents = True
End If
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Change the column width by a certain amount for all worksheets using VBA | 12 | 33 | |
Excel 2010 - Delete Row based on date | 8 | 34 | |
Dynamic Excel Input Form | 29 | 30 | |
Excel Spacing Anomaly | 4 | 22 |
Join the community of 500,000 technology professionals and ask your questions.