VBA Code - Add New Columns with Named Headers & Populate with Formulas

mbagz

New Member
Joined
Mar 22, 2017
Messages
14
Hey, I am trying to create a dynamic table in excel using VBA based on some primary fields:

QuantityFrequencyStartDateEndDateTotal TimepointsNew Column 1........New Column 8
5Weekly04/15/202105/13/2021=If(Frequency = "weekly", Days(EndDate,StartDate)/7,,)
10Weekly04/15/202106/10/2021=If(Frequency = "weekly", Days(EndDate,StartDate)/7,,)

I'd like to setup some VBA code to:
1) Find the max number of timepoint in column "Total Timepoints" & define as "ColNum"
2) Create New Columns (Based on ColNum +1)
3) Name New Columns by Day 0, Day 7, Day 14, Day 21...Day 56
4) Populate rows of new columns with "Quantity" specified for that row, but only up to that rows Total Timepoints +1. For example the 2nd row in the above table should have "5" for each cell from new columns created (Day 0, Day 7, Day 14, Day 21, Day 28); Row 3 should have quantity "10" for each cell from new columns (Day 0, Day 7,...,Day 56)

So far, I have the below, but I have no idea what I'm doing so any help would be really appreciated:
VBA Code:
Sub AutoAddColumns()

Dim Table As ListObject
Dim NumOfColumns As Integer
Dim iCnt As Integer
Dim h As Long, hdrs As Variant
Dim Rows As Integer

hdrs = Array("Day 0", "Day 7", "Day 14", "Day 21", "Day 28", "Day 35", "Day 42", "Day 49", "Day 56", "Day 63", "Day 70", "Day 77", "Day 84", "Day 91", "Day 98", "Day 105", "Day 112", "Day 119", "Day 126", "Day 133", "Day 140", "Day 147")

Set Table = Worksheets("Sheet1").ListObjects("TableName")

NumOfColumns = Application.WorksheetFunction.Max(Range("TableName[Total Timepoints]"))

For iCnt = 0 To NumOfColumns
        Table.ListColumns.Add
        Table.ListColumns(Table.ListColumns.Count).Name = hdrs(iCnt)
    Next

End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
722
Office Version
  1. 365
Platform
  1. Windows
Hi mbagz,

Try below code to add the columns ...
VBA Code:
Sub test()

With ActiveSheet
   Lc& = .Cells(1, Columns.Count).End(1).Column + 1
   Cnt& = (Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7
   .Cells(1, Lc).Resize(, Cnt) = [transpose("Day "&row(1:50)*7)]
End With

End Sub
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
722
Office Version
  1. 365
Platform
  1. Windows
Just noticed that I missed the last point to copy the values from column 1. Try revised code below ...
VBA Code:
Sub test2()

With ActiveSheet
   Lc& = .Cells(1, Columns.Count).End(1).Column + 1
   Cnt& = (Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7
   .Cells(1, Lc).Resize(, Cnt) = [transpose("Day "&row(1:50)*7-7)]
   Lr& = .Cells(Rows.Count, 1).End(3).Row - 1
   .Cells(2, Lc).Resize(Lr).Resize(, Cnt) = .Cells(2, 1).Resize(Lr).Value
End With

End Sub
 

mbagz

New Member
Joined
Mar 22, 2017
Messages
14
Just saw your last post. so I'm editing my comment. Thanks for addressing everything!

1) The number of columns created should be total timepoints +1, but I can edit this
2) For the quantity entered, it should be input up to the total timepoints +1. For example, The first row should have "5" input for Day 0, Day 7, Day 14, Day 21, and Day 28. Could you help with this part?
3) Is there a way to specify this code to a named table? This data may not be always static on the sheet, so I'm trying to see if coding it to the table is possible.
 
Last edited:

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
722
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

This should take care of all your points :)
VBA Code:
Sub test3()

With ActiveSheet.ListObjects(1).DataBodyRange
   Lc& = .Columns.Count + 1
   Cnt& = (Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7
   .Cells(1, Lc).Resize(, Cnt) = ""
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose("Day "&row(1:50)*7-7)]
   Lr& = .Rows.Count
   .Cells(1, Lc).Resize(Lr).Resize(, Cnt) = .Cells(1, 1).Resize(Lr).Value
End With

End Sub
 

mbagz

New Member
Joined
Mar 22, 2017
Messages
14
This should take care of all your points :)
VBA Code:
Sub test3()

With ActiveSheet.ListObjects(1).DataBodyRange
   Lc& = .Columns.Count + 1
   Cnt& = (Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7
   .Cells(1, Lc).Resize(, Cnt) = ""
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose("Day "&row(1:50)*7-7)]
   Lr& = .Rows.Count
   .Cells(1, Lc).Resize(Lr).Resize(, Cnt) = .Cells(1, 1).Resize(Lr).Value
End With

End Sub
Hey mse330,

It's still adding the quantity all the way through the table. Ideally, I'd like it to add "5" quantity from row 2 for the new 5 columns added (4 total timepoints +1). For quantity "10", it should add it all the way from new column 1 to new column 9 (8 total timepoints +1). Unfortunately, this code goes over my head, so I don't know how to modify that.

Thanks again!
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
722
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Assuming you have a formula to count total timepoints in column 5 ...
VBA Code:
Sub test4()

Dim c As Range

With ActiveSheet.ListObjects(1).DataBodyRange
   Cnt& = ((Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7) + 1
   .Cells(1, .Columns.Count + 1).Resize(, Cnt) = ""
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose(row(1:50))]
   
   Set c = .Cells(1)
   With .Offset(, 5).Resize(, Cnt)
      .Formula = "=if(" & c.Offset(, 4).Address(0, 1) & "+1>=" & .Cells(1).Offset(-1).Address(1, 0) & "+0," & c.Address(0, 1) & ","""")"
      .Value = .Value
   End With
   
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose("Day "&row(1:50)*7-7)]
End With

End Sub
 

mbagz

New Member
Joined
Mar 22, 2017
Messages
14
Assuming you have a formula to count total timepoints in column 5 ...
VBA Code:
Sub test4()

Dim c As Range

With ActiveSheet.ListObjects(1).DataBodyRange
   Cnt& = ((Application.Max(.Columns(4)) - Application.Min(.Columns(3))) / 7) + 1
   .Cells(1, .Columns.Count + 1).Resize(, Cnt) = ""
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose(row(1:50))]
  
   Set c = .Cells(1)
   With .Offset(, 5).Resize(, Cnt)
      .Formula = "=if(" & c.Offset(, 4).Address(0, 1) & "+1>=" & .Cells(1).Offset(-1).Address(1, 0) & "+0," & c.Address(0, 1) & ","""")"
      .Value = .Value
   End With
  
   .Parent.ListObjects(1).HeaderRowRange.Offset(, 5).Resize(, Cnt) = [transpose("Day "&row(1:50)*7-7)]
End With

End Sub
That works perfectly! Thank you so much!
 

mse330

Well-known Member
Joined
Oct 18, 2007
Messages
722
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback :)
 

Watch MrExcel Video

Forum statistics

Threads
1,130,210
Messages
5,640,872
Members
417,174
Latest member
diegomuser

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top