Add or Delete Columns Based on Cell Value - excel

Question

I'm trying to add columns (or delete them if the number is reduced) between where "ID" and "Total" are based on the cell value in B1.
How could this be done automatically every time the cell is updated?
Code I have so far
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Dim i As Integer
For i = 1 To Range("B1").Value
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
End If
End Sub

Answer 1

There are a number of issues in your code:
Unqualified range references refer to a default sheet object. While it won't be a problem in this instance (in a worksheet code behind module that object is sheet sheet containing the code, in any other module its the Activesheet), it's a bad habit to get into. Use the keyword Me to refer to the sheet the code is in.
When changing the sheet in a Worksheet_Change event, use Application.EnableEvents = False to prevent an event cascade (any time the code changes the sheet the event is called again)
Use an Error Handler to turn it back on (Application.EnableEvents = True)
Calculate how many columns to Insert or Delete based on existing columns
Range check the user input to ensure it's valid
Insert or delete in one block
On the assumption the "Totals" column contains a formula to sum the row (eg for 2 columns, row 4 it might be =Sum($C4:$D4), when you insert columns at column C the formula won't include the new columns. The code can update the formulas if required.
Target is already a range. No need to get its address as a string, then turn it back into a range, use it directly
Your code, refactored:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim NumColumnsRequired As Long
Dim NumExistingColumns As Long
Dim NumToInsertOrDelete As Long
Dim TotalsRange As Range
On Error GoTo EH
Set KeyCells = Me.Range("B1")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
' Validate Entry
If Not IsNumeric(KeyCells.Value) Then Exit Sub
NumColumnsRequired = KeyCells.Value
If NumColumnsRequired <= 0 Or NumColumnsRequired > 16380 Then Exit Sub
Application.EnableEvents = False
NumExistingColumns = Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column - 3
NumToInsertOrDelete = NumColumnsRequired - NumExistingColumns
Select Case NumToInsertOrDelete
Case Is < 0
' Delete columns
Me.Columns(3).Resize(, -NumToInsertOrDelete).Delete
Case Is > 0
' Insert columns
Me.Columns(3).Resize(, NumToInsertOrDelete).Insert CopyOrigin:=xlFormatFromLeftOrAbove
'Optional: update Total Formulas
Set TotalsRange = Me.Cells(Me.Rows.Count, Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column).End(xlUp)
If TotalsRange.Row > 3 Then
Set TotalsRange = Me.Range(TotalsRange, Me.Cells(4, TotalsRange.Column))
TotalsRange.Formula2R1C1 = "=Sum(RC3:RC" & TotalsRange.Column - 1 & ")"
End If
Case 0
' No Change
End Select
End If
EH:
Application.EnableEvents = True
End Sub

Answer 2

may try the code below to have the result like
code is more or less self explanatory
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
However to keep the Sum formula on total Column consistence with added column, may limit number of minimum columns to 2 and inserting columns in between existing columns, by changing following
If ColNum <= 1 Then Exit Sub
and
Columns(i - 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
also delete line inserting column heading
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
otherwise may add VBA code to change formula of total column to requirement.

Answer 3

You can try the following.
the named ranges are defined:
"B1" -> "ColumnNumber"
"B3" -> "Header.ID"
"F3" -> "Header.Total" (but it changes as you add / remove columns)"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim headerId As Range, headerTotal As Range, columnNumber As Range
Dim currentNumberOfColumns As Integer, targetNumberOfColumns As Integer
Dim columnsToAdd As Integer, columnsToRemove As Integer
Dim i As Integer
On Error GoTo error_catch
Application.EnableEvents = False
Set columnNumber = Me.Range("ColumnNumber")
If Not Application.Intersect(columnNumber, Target) Is Nothing Then
Set headerId = Me.Range("Header.ID")
Set headerTotal = Me.Range("Header.Total")
targetNumberOfColumns = columnNumber.Value
If targetNumberOfColumns <= 0 Then
Application.EnableEvents = True
Exit Sub
End If
currentNumberOfColumns = headerTotal.Column - headerId.Column - 1
Debug.Print "Currently there are " & currentNumberOfColumns & " columns"
If currentNumberOfColumns = targetNumberOfColumns Then
Application.EnableEvents = True
Exit Sub
Else
If targetNumberOfColumns > currentNumberOfColumns Then
columnsToAdd = targetNumberOfColumns - currentNumberOfColumns
Debug.Print "Need to add " & columnsToAdd & " columns"
For i = 1 To columnsToAdd
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Copy
headerTotal.EntireColumn.Select
Selection.Insert Shift:=xlToRight
Next i
Else
columnsToRemove = -(targetNumberOfColumns - currentNumberOfColumns)
Debug.Print "Need to remove " & columnsToRemove & " columns"
For i = 1 To columnsToRemove
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Delete Shift:=xlToLeft
Next i
End If
End If
End If
columnNumber.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
error_catch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub