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]

How would I change the code to only add 7 units to the date in row 4 and not the whole column?

 

[PCL]

"adding 7 units onto the copied date as well as the data instead"
Can you give more detail, show how the data is.
Reusing you example, only when there is a date there is 7 days added because is testing if a date exists: see IsDate

 

[Faintkitara]

OK so here is an example of the data after using your code:

row 4- 5/1 5/8 cp 3/3 3/10 cp

row 5- 20 27 30 40 47 22
row 6- 30 37 22 55 62 33
row 7- 35 42 44 23 30 48


The data in the column before current projection is supposed to match the data in the current projection column. So those two columns should be identicle, the only thing that should change is the fact that the column name changed to a date and the date should be 7 units after the date before it. So it should look like this:

row 4- 5/1 5/8 cp 3/3 3/10 cp

row 5- 20 30 30 40 22 22
row 6- 30 22 22 55 33 33
row 7- 35 44 44 23 48 48

 

[Faintkitara]

See my previous post, I just want to make it look more even so you can tell the difference:

This is what it looks like with the current code:


row 4- 5/1 5/8 cp 3/3 3/10 cp

row 5- 20 27 30 40 47 22
row 6- 30 37 22 55 62 33
row 7- 35 42 44 23 30 48

This is what it should look like:

row 4- 5/1 5/8 cp 3/3 3/10 cp

row 5- 20 30 30 40 22 22
row 6- 30 22 22 55 33 33
row 7- 35 44 44 23 48 48

 

[PCL]

Clear now.

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
            Cells(WkRow, J) = Cells(Rows.Count, J - 1) + NbD
            Range(Cells(WkRow + 1, J - 1), Cells(LR, J - 1)).Copy Destination:=Cells(WkRow + 1, J)
         Else
            Cells(WkRow, J) = WkW
         End If
      End If
   Next
End Sub

 

[Faintkitara]

I'm still having a slight problem with this code. Let me start over:

Step1:

row 4- 5/1 5/8 cp 3/3 3/10 cp

row 5- 20- 27- 30- 40- 47- 22
row 6- 30- 37- 22 -55- 62- 33
row 7- 35 -42- 44- 23 -30 -48



Step2:

the cp columns are to be duplicated right next to each other

row 4- 5/1 5/8 cp cp 3/3 3/10 cp cp

row 5- 20- 27- 30- 30- 40- 47-22-22
row 6- 30- 37- 22 -22- 55- 62-33-33
row 7- 35 -42- 44- 44 -23 -30-44-44



Step3:

and the leftmost cp column should instead of being named "cp", should be named a date that 7 units more than the column before it


row 4- 5/1 5/8 5/15 cp 3/3 3/10 3/17 cp
row 5- 20- 27- 30- 30- 40- 47-22-22
row 6- 30- 37- 22 -22- 55- 62-33-33
row 7- 35 -42- 44- 44 -23 -30-44-44


Hopefully this clears it up once and for all. The code you sent me copies the 5/8 column instead of the cp column and it doesn't add 7 to the date (but the code you sent previous to this current code you sent added 7 to the date so I'm going to just look at that code).

Sorry to keep messaging you lol. But its so close!

 

[PCL]

Is it what you want ...?

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
         LR = Cells(Rows.Count, J + 1).End(3).Row
         Range(Cells(WkRow, J + 1), Cells(LR, J + 1)).Copy Destination:=Cells(WkRow, J)
         If (IsDate(Cells(WkRow, J - 1))) Then
            Cells(WkRow, J - 1).Copy Destination:=Cells(WkRow, J)
            Cells(WkRow, J) = Cells(WkRow, J - 1) + NbD
         Else
            Cells(WkRow, J) = Cells(WkRow, J + 1)
         End If
      End If
   Next
End Sub

 

[Faintkitara]

Yes this is exactly what I want. Is there anyway to make it to where the values that are copied are just values and not the formulas in the cell. Next to that everything works great.

 

[PCL]

OK see here

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
         LR = Cells(Rows.Count, J + 1).End(3).Row
         Range(Cells(WkRow, J + 1), Cells(LR, J + 1)).Copy
         Cells(WkRow, J).PasteSpecial Paste:=xlPasteValues
         Cells(WkRow, J).PasteSpecial Paste:=xlPasteFormats
         If (IsDate(Cells(WkRow, J - 1))) Then
            Cells(WkRow, J - 1).Copy Cells(WkRow, J)
            Cells(WkRow, J) = Cells(WkRow, J - 1) + NbD
         Else
            Cells(WkRow, J) = Cells(WkRow, J + 1)
         End If
      End If
   Next
End Sub

 

[Faintkitara]

YES This is perfect! Thank you for your patience and I appreciate the help.