Copy range from excel sheet to new one with name range

Question

I have a workbook with a protected sheet which has predefined formats and formulas, and particular section of sheet has a drop-down with Actual and Forecast options.

When a user selects Actual in the drop-down, all the corresponding cells' formulas get converted to values (using paste special) and cannot be recalled. However, I need to revert this and recall all the formulas once the user has selected Forecast again on the sheet. This drop-down value is Column specific.

I am using below code to "paste special as values" and have the formulas in a Template sheet for copying back of the formulas.

The area I need help in is how to paste them in the destination cell

If ActiveCell.Value = "Actual" Then

    If Sheets("Template").Range("B1").Value <> 1 Then

        Answer = MsgBox("Once you change this drop down to 'Actual' the formulas below in the monthly breakdown section will be changed to constant values; and will not be revereted back", vbYesNo)

        If Answer = vbNo Then
            Application.Undo
            Application.StatusBar = ""
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Exit Sub
        End If

    End If

    Sheets("Template").Range("B1").Value = 1
    arrng = Cellinrng(ActiveCell)

    If InStr(1, arrng(0), "PrjRel") = 0 Then

        Application.DisplayAlerts = False
        Exit Sub

    Else

        If ActiveCell.Row = Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-4, 0).Row Then

            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Dim activcell
            Set activcell = ActiveCell
            Call sbUnProtectSheet(ActiveSheet.Name)

            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-1, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(1, ActiveCell.Column - 2).Address).Copy
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-1, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(1, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address).Copy
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address).Copy
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address).Copy
            Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
            Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($C" & (ActiveCell.Row - 5) & ",0,0,ROW($C" & (ActiveCell.Row - 5) & ")-ROW($C" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($C" & (ActiveCell.Row - 5) & ")),""Actual"",Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6) & ")"
            Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
            Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
            Application.CutCopyMode = False


            Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
            Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($D" & (ActiveCell.Row - 5) & ",0,0,ROW($D" & (ActiveCell.Row - 5) & ")-ROW($D" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($D" & (ActiveCell.Row - 5) & ")),""Actual"",sumRange)"
            Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
            Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
            Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($D" & (ActiveCell.Row - 5) & ",0,0,ROW($D" & (ActiveCell.Row - 5) & ")-ROW($D" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($D" & (ActiveCell.Row - 5) & ")),""Actual"",sumRange)"
            Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
            Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If

    End If

End If

EEM EEM · Accepted Answer · 2017-01-07T05:29:45

The approach you are taking requires to many coding lines and will be hard to maintain if changes are required.

The solution I’m proposing uses the Worksheet_Change event to trigger the Procedures to Change the Formulas to values and to Restate the Formulas, it also uses the Range.SpecialCells Method (Excel) to identify the cells that need to be processed. This will ease the maintenance of your procedures in case of changes.

This solutions assumes that:

The worksheet that users will change to Actual or Forecast is named DATA and the DataValidation is located at D4 (change as required)
The worksheet with the standard formulas is named Template (change as required)
The worksheet DATA is a replica of the worksheet Template and both worksheets are protected (change as required)

Solution:

Copy this code in the VBA Module of the worksheet DATA

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Const kCll As String = "$D$4"
    With Target.Cells(1)
        If .Address = kCll Then Call WshAct_Actual_Or_Forecast(CStr(.Value2), .Worksheet)
    End With
End Sub

Copy this code in a Standard VBA Module

Option Explicit

Public Sub WshAct_Actual_Or_Forecast(sCllVal As String, wshTrg As Worksheet)
Dim rTrg As Range

    Rem Application Settings Off
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Rem Set Target Range to Process
    Set rTrg = wshTrg.Range("E7:AB16")      'change as required
    ' In Procedures "Wsh_SetFormulas_ToValues" and "Wsh_SetFormulas_FromTemplate"
    '     the Target Range to Process is optional.
    '     Therefore if the Target Range is not provided the procedures
    '     will process the UsedRange of the Target Worksheet.

    Rem Validate Cell Value
    Select Case sCllVal
    Case "Actual"

        Rem Add here any required validation!


        Rem Message to User
        If MsgBox(Title:="Data Type [" & sCllVal & "]", _
            Prompt:="Formulas in the monthly breakdown will be changed to constant values" & _
                vbLf & vbLf & vbTab & "Do you want to continue?", _
            Buttons:=vbSystemModal + vbMsgBoxSetForeground + vbQuestion + vbOKCancel) = vbCancel Then GoTo ExitTkn

        If rTrg Is Nothing Then
            Rem To change all formulas in target worksheet
            Call Wsh_SetFormulas_ToValues(wshTrg)
        Else
            Rem To change formulas only in Target Range
            Call Wsh_SetFormulas_ToValues(wshTrg, rTrg)
        End If

    Case "Forecast"
        Rem Add here any required validation!


        If rTrg Is Nothing Then
            Rem To restate all formulas in target worksheet
            Call Wsh_SetFormulas_FromTemplate(wshTrg)
        Else
            Rem To restate formulas only in Target Range
            Call Wsh_SetFormulas_FromTemplate(wshTrg, rTrg)
        End If

    End Select

ExitTkn:
    Rem Application Settings ON
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub


Sub Wsh_SetFormulas_ToValues(wshTrg As Worksheet, Optional ByVal rTrg As Range)
Dim rArea As Range
    Call Wsh_Protection_OFF(wshTrg) 'change as required

    Rem Validate\Set Target Range
    If rTrg Is Nothing Then Set rTrg = wshTrg.UsedRange

    Rem Set Target Range to Values
    For Each rArea In rTrg.Areas
        With rArea
            .Value = .Value2
    End With: Next

    Call Wsh_Protection_ON(wshTrg)  'change as required

End Sub


Sub Wsh_SetFormulas_FromTemplate(wshTrg As Worksheet, Optional ByVal rTrg As Range)
Const kWshSrc As String = "Template"
Dim wshSrc As Worksheet
Dim rSrc As Range, rSrcArea As Range, rTrgArea As Range

    Rem Set Source Worksheet - Template
    On Error Resume Next
    Set wshSrc = ThisWorkbook.Worksheets(kWshSrc)
    On Error GoTo 0
    If wshSrc Is Nothing Then
        MsgBox "Template Worksheet is missing!", _
            vbSystemModal + vbCritical + vbMsgBoxSetForeground
        Exit Sub
    End If

    Call Wsh_Protection_OFF(wshSrc)
    Call Wsh_Protection_OFF(wshTrg)

    Rem Validate\Set Target Range
    If rTrg Is Nothing Then Set rTrg = wshTrg.UsedRange

    Rem Set Source Formula Range
    Set rSrc = wshSrc.Range(rTrg.Address).SpecialCells(xlCellTypeFormulas, _
        xlErrors + xlLogical + xlNumbers + xlTextValues)

    Rem Set Target Range Formulas
    For Each rSrcArea In rSrc.Areas

        Set rTrgArea = wshTrg.Range(rSrcArea.Address)
        rSrcArea.Copy
        rTrgArea.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
        Application.CutCopyMode = False

    Next

    Call Wsh_Protection_ON(wshTrg)
    Call Wsh_Protection_ON(wshTrg)

End Sub

Suggest to read the following pages to gain a deeper understanding of the resources used:

For Each...Next Statement, Range Object (Excel), Select Case Statement,

Worksheet Object Events, With Statement.

Copy range from excel sheet to new one with name range

1 Answers