vba code for excel formula

Hi Dev

Is your Pune Sheet complete or might there be additional items?

Hi Dev

Will there be new Formulas with these new additions? Can you supply a Table of all possible Formulas?

Hi Dev

The attached File has an "Initial Set Up" routine that creates a Sheet called "Lists". This Sheet contains a Table of all the Formulas as extracted from Sheet Pune. It also CLEARS ALL DATA AND FORMULAS from Sheet Pune, Columns C to the last Column to the Right.

This Code must be run ONLY ONCE as it destroys all Formulas in Sheet Pune. The Code is in Module 2 and can be executed with CTRL + x

Option Explicit

Sub Initial_Setup()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim LR As Long, i As Long, LC As Long
    Dim cel As Range
    Dim LastValue As String

    Application.ScreenUpdating = False
    Set ws = Sheets("Pune")
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If
    Set ws1 = Sheets("Lists")

    With ws
        .Unprotect
        LR = .Columns("A").Find(What:="TOTAL", LookIn:=xlValues, lookat:=xlPart).Row - 1
        LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
        .Range("A3:D" & LR).Copy ws1.Range("A3")
        With ws1
            .Activate
            LastValue = ""
            For Each cel In .Range("A4:A" & LR)
                If Trim(cel.Value) <> "" Then
                    LastValue = cel.Value
                Else
                    If LastValue <> "" Then cel.Value = LastValue
                End If
            Next cel
            ActiveWindow.DisplayFormulas = True
        End With
        For i = 3 To LC Step 1
            .Range(.Cells(3, i), .Cells(LR, i)).ClearContents
        Next i
        .Protect
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

In Sheet Pune all of the Data Entry Cells have been unlocked (Columns C, E, G, etc to the Right). This Code is in the Workbook Open Event and Protects Sheet Pune but allows Macros to Update the Sheet

Option Explicit

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Set ws = Sheets("Pune")
    'set protection using UserInterface to allow macros to work
    With ws
        .Protect _
                DrawingObjects:=True, _
                Contents:=True, _
                Scenarios:=True, _
                AllowFiltering:=True, _
                UserInterfaceOnly:=True
        .EnableSelection = xlUnlockedCells
    End With
End Sub

This is the Code that does the Dirty work...it's in the Sheet Module of Pune

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myFormula As String
    If Target.Cells.Count > 1 Then Exit Sub
    Select Case Target.Column
    Case 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25
        Application.EnableEvents = False
        myFormula = Replace(Sheets("Lists").Cells(Target.Row, "D").Text, "C", ColumnLetter(Target.Column))

        Target.Offset(0, 1).Value = myFormula
        Target.Offset(0, 1).Value = Target.Offset(0, 1).Value
        Application.EnableEvents = True
    Case Else
        Exit Sub
    End Select
End Sub


Function ColumnLetter(ColumnNumber As Long) As String
' From http://www.craigmurphy.com/blog/?p=150
' Works in Excel 2007
    Dim ColNum As Integer
    Dim ColLetters As String
    ColNum = ColumnNumber
    ColLetters = ""
    Do
        ColLetters = Chr(((ColNum - 1) Mod 26) + 65) & ColLetters
        ColNum = Int((ColNum - ((ColNum - 1) Mod 26)) / 26)
    Loop While ColNum > 0
    ColumnLetter = ColLetters
End Function

You can add as many Columns to the Right as you wish. You CANNOT add rows (you can but it requires special instructions). Let me know of issues.

You're welcome...glad I could help.

If you're satisfied by any members response to your issue please use the star icon at the lower left of their post.