Macro to Duplicate Specifically named Columns and Rename them as a date

[Faintkitara]

Hello,

I'm trying to figure out how to make a macro that copies all columns named " Current Projection" in row 4 and pastes them right after each other. So wherever a column says "Current Projection" in row 4 i pretty much want that column to be duplicated. I tried doing this myself but of course macrorecorder can only go so far. For example row 4 would look like this (with corresponding data below it):

[TABLE="width: 500"]
<tbody>[TR]
[TD]5/5[/TD]
[TD]5/12[/TD]
[TD]Current Projection[/TD]
[TD]Accounts[/TD]
[TD]Current Projection[/TD]
[TD]Totals[/TD]
[/TR]
</tbody>[/TABLE]

I want it to look like this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]5/5[/TD]
[TD]5/12[/TD]
[TD]Current Projection [/TD]
[TD]Current Projection[/TD]
[TD]Accounts[/TD]
[TD]Current Projection[/TD]
[TD]Current Projection [/TD]
[TD]Totals[/TD]
[/TR]
</tbody>[/TABLE]



On top of that I also wanted to get code on how to rename every first "Current Projection" column of the duplicates, a date that is seven days more than the date listed the column before it.

So from this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]5/5[/TD]
[TD]5/12[/TD]
[TD]Current Projection[/TD]
[TD]Current Projection[/TD]
[TD]Accounts [/TD]
[TD]7/2[/TD]
[TD]7/9[/TD]
[TD]Current Projection[/TD]
[TD]Current Projection[/TD]
[TD]Totals[/TD]
[/TR]
</tbody>[/TABLE]

To this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]5/5[/TD]
[TD]5/12[/TD]
[TD]5/19[/TD]
[TD]Current Projection[/TD]
[TD]Current Projection[/TD]
[TD]Accounts[/TD]
[TD]7/2[/TD]
[TD]7/9[/TD]
[TD]7/16[/TD]
[TD]Current Projection[/TD]
[/TR]
</tbody>[/TABLE]


Any response would be greatly appreciated! Thank you!!!

 

[Faintkitara]

Sorry the Last example should NOT have two "Current Projection" cells. Only one, didnt know how to edit my previous post

 

[PCL]

In your first example
5/5 [TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]5/12[/TD]
[TD]Current Projection[/TD]
[TD]Accounts[/TD]
[TD]Current Projection
[/TD]
[TD]Totals[/TD]
[/TR]
</tbody>[/TABLE]

there is no date on the left of the second "Current Projection" is it possible, do we need to check if a date exists ?

 

[Faintkitara]

In your first example
5/5 [TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]5/12[/TD]
[TD]Current Projection[/TD]
[TD]Accounts[/TD]
[TD]Current Projection[/TD]
[TD]Totals[/TD]
[/TR]
</tbody>[/TABLE]

there is no date on the left of the second "Current Projection" is it possible, do we need to check if a date exists ?

Well, this is just an example, but there could be dates on the left and there may not be (i would suggest that you check)

 

[PCL]

Try

Option Explicit

Sub Treat()
Const WkRow  As Integer = 4
Const WkW As String = "Current Projection"
Const NbD  As Integer = 7
Dim LC  As Integer, J As Integer


   LC = Cells(WkRow, Columns.Count).End(xlToLeft).Column
   For J = LC To 1 Step -1
      If (Cells(WkRow, J) = WkW) Then
         Columns(J).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
         If (IsDate(Cells(WkRow, J - 1))) Then
            Cells(WkRow, J) = Cells(WkRow, J - 1) + NbD
         Else
            Cells(WkRow, J) = WkW
         End If
      End If
   Next
End Sub

 

[Faintkitara]

This is greaat! You are brilliant sir!

I did hit a snag though. The column "Current Projection" is copied and the name is changed to the date but the data listed below it is not copied. Under neath the column it completely blank. Is there something in the code that can be slightly changed? I will try to see what the error is on my own as well.

 

[PCL]

See next code

Option Explicit

Sub Treat()
Const WkRow  As Integer = 4
Const WkW As String = "Current Projection"
Const NbD  As Integer = 7
Dim LC  As Integer, J As Integer
Dim LR  As Integer

   LC = Cells(WkRow, Columns.Count).End(xlToLeft).Column
   For J = LC To 1 Step -1
      If (Cells(WkRow, J) = WkW) Then
         Columns(J).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
         If (IsDate(Cells(WkRow, J - 1))) Then
            LR = Cells(Rows.Count, J - 1).End(3).Row
            With Range(Cells(WkRow, J), Cells(LR, J))
               .Cells.Formula = "=RC[-1]+" & NbD
               .Value = .Value
            End With
         Else
            Cells(WkRow, J) = WkW
         End If
      End If
   Next
End Sub

 

[Faintkitara]

This is great thanks! One more tiny request. How can I change it to where I copy the value instead of the formula when duplicating the column. And what Can I input into the code to make it to where the formatting is clear for the duplicate columns as well. I promise this is it lol (wish I could you points or likes or something)

 

[PCL]

"I copy the value instead of the formula when duplicating the column. And what"
The macro is using a formula to copy the date (to be sure there is 7 days difference what ever the date) but at the end values are frozen : no more formulas ....!
"the formatting is clear for the duplicate columns"
The format for duplicated columns is the same that the one on the left: To reuse date format
=> from where do you want the format coming from ???

 

[Faintkitara]

After looking closer at the data, I realized that the macro is adding 7 units onto the copied date as well as the data instead of just adding 7 units to the date and leaving the data alone.

And ok, I get what you are saying about the clear formatting.