Enter the result of a formula using VBA

[Jim G]

I use the following code to enter formulae into a sheet that has three
columns for each month (Actual, Adjustment,Net-starting at row 12). Each
month new data is added to the Data Sheet. The formulae are added to each
line (starting at row 13)and the month actuals updated. Is it possible to
enter the result of the formula in each row or should I just copy the column
and paste values after the main code has run?

I would also appreciate any ideas on error handling to allow the use to back
out if they don't want to make the choice of starting cell.

The data sheet has a date that I would like to validate against the column
date (cell above Actual-row 11) and warn or terminate the code.
--------------------------------------------
Option Explicit

Sub Formula()
' Enters formulas in current month "ACTUAL" column to retreive PFRM data
Dim col As String
Dim adjCol As String
Dim Col2 As String
Dim iRow As Long, r As Long
Dim Net As Range
Dim rngInput As Range
Dim CalcType As Variant
Dim ProjResult As String
Dim Projnet As String
Dim Lastrow As Long

Worksheets("Cheops").Select
Rows(13).Select 'to ensure the screen is at the first row for input

With Application
CalcType = .Calculation
.Calculation = xlCalculationManual
End With

' to select the column of the current month
Set rngInput = Application.InputBox("Select Starting Cell in Highlighted
Row", Type:=8)

Application.ScreenUpdating = False

col = Split(rngInput.Address, "$")(1)
Col2 = Split(rngInput.Offset(0, 2).Address, "$")(1)
adjCol = Split(rngInput.Offset(0, 1).Address, "$")(1)
iRow = rngInput.Row

ProjResult = "=SUMIF(Data!$A:$A,$A" & iRow &
",Data!$D:$D)+SUMIF(Data!$C:$C,$C" & iRow & ",Data!$D:$D)"
Debug.Print (ProjResult) ' temp test the for result
Projnet = "=(" & col & iRow & "+" & adjCol & iRow & ")"

With Worksheets("Cheops")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(col & iRow & ":" & col & Lastrow).Value = ProjResult
.Range(Col2 & iRow & ":" & Col2 & Lastrow).Formula = Projnet

End With
With Application
.ScreenUpdating = True
.Calculation = CalcType
End With


End Sub

 

[Bob Phillips]

Sub Formula()
' Enters formulas in current month "ACTUAL" column to retreive PFRM data
Dim col As String
Dim adjCol As String
Dim Col2 As String
Dim iRow As Long, r As Long
Dim Net As Range
Dim rngInput As Range
Dim CalcType As Variant
Dim ProjResult As String
Dim Projnet As String
Dim Lastrow As Long

Worksheets("Cheops").Select
Rows(13).Select 'to ensure the screen is at the first row for input

With Application
CalcType = .Calculation
.Calculation = xlCalculationManual
End With

' to select the column of the current month
On Error Resume Next
Set rngInput = Application.InputBox("Select Starting Cell in Highlighted
Row ", Type:=8)
On Error GoTo 0

If Not rngInput Is Nothing Then

Application.ScreenUpdating = False

col = Split(rngInput.Address, "$")(1)
Col2 = Split(rngInput.Offset(0, 2).Address, "$")(1)
adjCol = Split(rngInput.Offset(0, 1).Address, "$")(1)
iRow = rngInput.Row

ProjResult = "=SUMIF(Data!$A:$A,$A" & iRow &
",Data!$D:$D)+SUMIF(Data!$C:$C,$C" & iRow & ",Data!$D:$D)"
Debug.Print (ProjResult) ' temp test the for result
Projnet = "=(" & col & iRow & "+" & adjCol & iRow & ")"

With Worksheets("Cheops")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(col & iRow & ":" & col & Lastrow).Value = ProjResult
.Range(col & iRow & ":" & col & Lastrow).Value = _
.Range(col & iRow & ":" & col & Lastrow).Value
.Range(Col2 & iRow & ":" & Col2 & Lastrow).Formula = Projnet
.Range(Col2 & iRow & ":" & Col2 & Lastrow).Value = _
.Range(Col2 & iRow & ":" & Col2 & Lastrow).Value

End With
With Application
.ScreenUpdating = True
.Calculation = CalcType
End With
End If
End Sub



--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Jim G]

Thanks bob, so simple yet so effective, you're a genius!

Any thoughts on the date match?

 

[Bob Phillips]

Jim,

I am not sure where the date cell is, which cell you want to compare
against, or where you want that check in the code, but testing cells is just
a simple IF test

If cell1 = cell2 Then

and so on.

--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Jim G]

The "new month date" is always in Sheets("Data") at cell F1. However the
comparable date will always be the heading of the column the formula values
are written to in Sheets("Cheops") and therefore changes each month.

'Im trying to use MthDate = rngInput.offset(-3,0) but I think I have the
wrong syntax. I want to test it after the input selection and warn if it's
not equal (data period mismatch).

 

[Jim G]

The date field in "Data" was importing as text so there was a type mismatch
that I've been able to fix to solve "date=rngInput.offset(-3,0)".

 

[Bob Phillips]

Just caught your response. Does this mean you are fixed now?

--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Jim G]

Thanks Bob,
After a small hicup all seems to be working well, but I've still a fair bit
of testing to do and then create templates for all the projects. I'm sure
I'll be looking for more advice.

I have one small favour to ask. I have the follwing code (extract) that
locates the text file that I'm manipulating. I have set the path in the code
and if the user goes outside the set path I get an error "file not found".
Is this because I have fixed it in concrete, so to speak. It's not a real
problem since I want to restirict where the user can find the file due to
version control concerns. I'm more curious as to how I would make a change
to make it so I could navigate to any location (but start in a specified
location) while I'm testing.

Is it also possible to have the coursor go to a specified cell address
depending on a given date being found in the range?

Sub PFRMImportUG() ' will ask user for a PFRM file (text or print dump) to
import

Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Select ""YES"" to proceed to Open a PFR File, ""NO"" to view this
file only"
Style = vbYesNoCancel + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Open a New PFR File " ' Define title.

Response = MsgBox(Msg, Style, Title, Help, Ctxt)

If Response = vbYes Then

Dim readfilename As Variant
Dim wkbk As Workbook
Dim MyPath As String

MyPath = "N:\MINING\ACCOUNTS\Operation Accounts\Underground\ProjData\"
'MyPath = "T:\" ' testing directory
'readfilename = "PFRM102Dec06" ' test file
ChDrive MyPath
ChDir MyPath

readfilename = Application.GetOpenFilename("All Files (*.*),*.*,Text Files
(*.txt),*.txt,Comma Seperated Value Files (*.csv),*.csv,Excel Files
(*.xls),*.xls")

If readfilename = False Then
Exit Sub 'user hit cancel
End If

' Set wkbk = Workbooks.Open(Filename:=readfilename)

Else
Exit Sub
End If