[ad_1]
The code as it is, it inserts/removes columns based on a cell value. It works good, but it only copies the format of the cells from the first column and not formulas. I need for the following code to also copy the formulas from the previous column. Does anybody know what line I can add?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
' e.g. to prevent
' "Run-time error '1004': Microsoft Excel can't insert new cells because
' it would push non-empty cells off the end of the worksheet.
' These non-empty cells might appear empty but have blank values,
' some formatting, or a formula. Delete enough rows or columns
' to make room for what you want to insert and then try again.",
' which is covered for the header row, as long there is nothing
' to the right of the total column, but not for other rows.
Const TargetCellAddress As String = "C2"
Const TotalFirstCellAddress As String = "D4"
Const TotalColumnTitle As String = "Total" ' case-insensitive
Dim TargetCell As Range
Set TargetCell = Intersect(Me.Range(TargetCellAddress), Target)
If TargetCell Is Nothing Then Exit Sub ' cell not contained in 'Target'
Dim NewTotalIndex As Variant: NewTotalIndex = TargetCell.Value
Dim isValid As Boolean ' referring to an integer greater than 0
If VarType(NewTotalIndex) = vbDouble Then ' is a number
If Int(NewTotalIndex) = NewTotalIndex Then ' is an integer
If NewTotalIndex > 0 Then ' is greater than 0
isValid = True
End If
End If
End If
If Not isValid Then Exit Sub
Dim hrrg As Range ' Header Row Range
Dim ColumnsDifference As Long
With Range(TotalFirstCellAddress)
Set hrrg = .Resize(, Me.Columns.Count - .Column + 1)
If NewTotalIndex > hrrg.Columns.Count Then Exit Sub ' too few columns
ColumnsDifference = .Column - 1
End With
Dim OldTotalIndex As Variant
OldTotalIndex = Application.Match(TotalColumnTitle, hrrg, 0)
If IsError(OldTotalIndex) Then Exit Sub ' total column title not found
Application.EnableEvents = False
Dim hAddress As String
Select Case OldTotalIndex
Case Is > NewTotalIndex ' delete columns
hrrg.Resize(, OldTotalIndex - NewTotalIndex).Offset(, NewTotalIndex _
- ColumnsDifference + 2).EntireColumn.Delete xlShiftToRight
Case Is < NewTotalIndex ' insert columns
With hrrg.Resize(, NewTotalIndex - OldTotalIndex) _
.Offset(, OldTotalIndex - 1)
' The above range becomes useless after inserting too many columns:
hAddress = .Address
.EntireColumn.Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
End With
With Me.Range(hAddress)
.Formula = "=""""&COLUMN()-" & ColumnsDifference - 1
.Value = .Value
End With
Case Else ' is equal; do nothing
End Select
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Thanks beforehand!
[ad_2]