Add/Remove columns, date range, based on value of a cell

[dkmiller16]

I am working on a weight loss % tracker. I specify the start date, M2, as well as the weigh in intervals, M3. I would like to have a place to enter how many cycles or intervals that we want to do this for. In the example below I have 5 weigh ins. If I want to run this for 8 weeks I can insert columns, copy/paste formulas and then make sure all the formulas are calculating properly. That's a bit time consuming but possible on my end. I would like to share this with friends that are not at all used to working in Excel and changing the cycle amount wouldn't be an option for them. I tried all kinds of searches but I wasn't sure how to word the search and was drawing a blank.

Thanks

 

[Dossfm0q]

What abou

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim LstRw As Long, PrvsLstCol As Long, CurrLstCol As Long, PrvsVal As Long, CurtVal As Long
Dim SrcRng As Range, FllRng As Range
 
PrvsLstCol = Cells(3, Columns.Count).End(xlToLeft).Column
LstRw = Cells(Cells.Rows.Count, PrvsLstCol).End(xlUp).Row
 
    Application.EnableEvents = False
     If Not Intersect(Target, Cells(3, PrvsLstCol)) Is Nothing Then
        Application.Undo
        DateVal = Cells(2, PrvsLstCol).Value
        PrvsVal = Cells(3, PrvsLstCol).Value
        Application.Undo
        CurtVal = Cells(3, PrvsLstCol).Value
               ' Rest Last Column
               CurrLstCol = (CurtVal * 2) + 3
               'Titel
                With Cells(1, 1).Resize(1, CurrLstCol)
                .HorizontalAlignment = xlCenterAcrossSelection
                .Interior.Color = .Cells(1, 1).Interior.Color
                End With
                'Date
                With Cells(2, CurrLstCol)
                .Value = DateVal
                End With
                With Cells(2, PrvsLstCol)
                .Value = ""
                End With
                'Cycle
                With Cells(3, CurrLstCol)
                .Value = CurtVal
                End With
                With Cells(3, PrvsLstCol)
                .Value = ""
                End With
                '
                With Cells(5, PrvsLstCol).Resize(LstRw + 1 - 5, 1)
                .Copy Destination:=Cells(5, CurrLstCol)
                .Value = ""
                End With
              
            If CurtVal > PrvsVal Then
                With Cells(5, PrvsLstCol - 2).Resize(1, 2)
               .AutoFill Destination:=Cells(5, PrvsLstCol - 2).Resize(1, 2 + (CurrLstCol - PrvsLstCol))
                End With
            Else
                With Cells(1, CurrLstCol + 1).Resize(LstRw + 1 - 1, PrvsLstCol - CurrLstCol)
                .Clear
                End With
            End If
 
  
    
     End If
    Application.EnableEvents = True
 
End Sub

 

[Dossfm0q]

Try this

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim LstRw As Long, PrvsLstCol As Long, CurrLstCol As Long, PrvsVal As Long, CurtVal As Long
Dim SrcRng As Range, FllRng As Range
 
PrvsLstCol = Cells(3, Columns.Count).End(xlToLeft).Column
LstRw = Cells(Cells.Rows.Count, PrvsLstCol).End(xlUp).Row
 Dim r As Range
    Application.EnableEvents = False
     If Not Intersect(Target, Cells(3, PrvsLstCol)) Is Nothing Then
        Application.Undo
        DateVal = Cells(2, PrvsLstCol).Value
        PrvsVal = Cells(3, PrvsLstCol).Value
        Application.Undo
        CurtVal = Cells(3, PrvsLstCol).Value
               ' Rest Last Column
               CurrLstCol = (CurtVal * 2) + 3
               'Titel
                With Cells(1, 1).Resize(1, CurrLstCol)
                .HorizontalAlignment = xlCenterAcrossSelection
                .Interior.Color = .Cells(1, 1).Interior.Color
                End With
                With Cells(2, 2).Resize(1, CurrLstCol - 4)
                .HorizontalAlignment = xlCenterAcrossSelection
                .Interior.Color = .Cells(1, 2).Interior.Color
                End With
                With Cells(3, 2).Resize(1, CurrLstCol - 4)
                .HorizontalAlignment = xlCenterAcrossSelection
                .Interior.Color = .Cells(1, 2).Interior.Color
                End With
                'Date
                With Cells(2, CurrLstCol)
                .Value = DateVal
                End With
                With Cells(2, PrvsLstCol)
                .Value = ""
                End With
                'Cycle
                With Cells(3, CurrLstCol)
                .Value = CurtVal
                End With
                With Cells(3, PrvsLstCol)
                .Value = ""
                End With
                '
                With Cells(5, PrvsLstCol).Resize(LstRw + 1 - 5, 1)
                .Copy Destination:=Cells(5, CurrLstCol)
                .Value = ""
                End With
              
            If CurtVal > PrvsVal Then
                With Cells(5, PrvsLstCol - 2).Resize(2, 2)
               .AutoFill Destination:=Cells(5, PrvsLstCol - 2).Resize(2, 2 + (CurrLstCol - PrvsLstCol))
                End With
            Else
                With Cells(1, CurrLstCol + 1).Resize(LstRw + 1 - 1, PrvsLstCol - CurrLstCol)
                .Clear
                End With
            End If
            
        With Cells(7, 1).Resize(LstRw + 1 - 7, CurrLstCol)
            .Cells.FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=" & .Address(False, True) & "<>"""""
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
           .FormatConditions(.FormatConditions.Count).Borders.LineStyle = xlContinuous
            .FormatConditions(1).StopIfTrue = False
        End With
 
 
    
     End If
    Application.EnableEvents = True
 
End Sub

with this table

Add Remove columns, date range, based on value of a cell.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Weight Loss % Tracker
2	WEIGHTLOSS COMPETITION	Set Competition Start Date											1/1/2021
3				SetWeight Measureed Interval [DAYS]:									5
4
5	Name	Starting weight [LP]	weight [LP]	Result	weight [LP]	Result	weight [LP]	Result	weight [LP]	Result	weight [LP]	Result	weight [LP]
6		04/01/2021	11/01/2021		18/01/2021		25/01/2021		01/02/2021		08/02/2021		5
7	XX												5
8	YY												5
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A7:M8	Expression	=$A7:$M8<>""	text	NO

to be like this