Copy column(s) and insert Code

[MyKey]

All Help appreciated. Thanks so much for Helping
I have multiple sheets with information in them. In each Sheet named Total,
there is a column or columns heading named Current. For sheet with just one
"Current" that means I have one column but for those that are multiple with
Current (I merge the Columns and named them Current)
Every time I usually copy the columns or column and insert back on the
column(s) leaving me with same double information.

Can any one help me with the code that will copy all the column(s) with
heading Current and insert back across sheet without doing this manually. The
word Current is on row 5. Then delete the word Current on the old column and
leave it blank while the new column(s) created have Current. After then I
want to copy information in row 52 and row 60 under the word current and
paste as values in the old column(s). The WORD CURRENT is inside cell(s) that
is or are formatted, if the formatting can be removed from the old cells that
will be awesome.

E.g Before the code,
The Heading Current is on column 1 and 2 after merging the row with the
heading.
Sheet 1_Total
Col 1 Col 2
Current
1 20
2 4
3 2
4 45

Sheet 2_Total
Col 5
Current
50
30
2
6

After the code execution I want for Sheet1_Total
Current
1 20 1 20
2 4 2 4
3 2 3 2
4 45 4 45

For Sheet2_Total
Current
50 50
30 30
2 2
6 6

After then I want to copy information in row 52 and row 60 under the word
heading current and paste as values in the old column(s).

Thanks so much for your support.

 

[Joel]

This code is not tested but I think will work. Let me know if there are
problems.

Sub Gettotals()

For Each sht In Sheets
If UCase(Right(sht.Name, 5)) = "TOTAL" Then
With sht
'get current column in row 5
Set c = .Rows(5).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 5")
Else
'copy data to next column
LastRow = .Cells(5, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(5, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy Destination:=c.Offset(0, 1)
'Clear out word current
c.ClearContents

Row6Col = c.Column
'get current column in row 52
Set c = .Rows(52).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 52")
Else
'copy data to row 6
LastRow = .Cells(52, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(53, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy
.Cells(6, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Remove formating
.Cells(52, c.Column).Copy
.Cells(52, c.Column).PasteSpecial _
Paste:=xlPasteValues
End If

'get current column in row 60
Set c = .Rows(60).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 60")
Else
'copy data to first emty cell below row 5/6
LastRow = .Cells(60, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(61, c.Column), _
.Cells(LastRow, c.Column))
'find last row with data below row 5/6
LastRow = .Cells(5, Row6Col).End(xlDown).Row
CopyRange.Copy
.Cells(LastRow, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Remove formating
.Cells(60, c.Column).Copy
.Cells(60, c.Column).PasteSpecial _
Paste:=xlPasteValues
End If
End If
End With
End If
Next sht
End Sub

 

[MyKey]

It is not responding. I get no error or execution. When I run the code
nothing happened. Please help.. what am I doing wrong?

Thanks for helping me thus far, i really appreciate it.

 

[Joel]

I suspect that the sheet name is matching the filter I used which is the last
5 characters of the sheet name ends in "TOTAL". I added a msgbox to the code
below. If no message occurs then the name of the sheet is wrong. Maybe you
have a zero instead of the letter O in the sheet name? I'm using UCASE sso
it shouldn't matter if the sheet name is using small of capital letters.

Sub Gettotals()

For Each sht In Sheets
If UCase(Right(sht.Name, 5)) = "TOTAL" Then
msgbox("Modifying sheet : " & Sht.name)
With sht
'get current column in row 5
Set c = .Rows(5).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 5")
Else
'copy data to next column
LastRow = .Cells(5, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(5, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy Destination:=c.Offset(0, 1)
'Clear out word current
c.ClearContents

Row6Col = c.Column
'get current column in row 52
Set c = .Rows(52).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 52")
Else
'copy data to row 6
LastRow = .Cells(52, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(53, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy
.Cells(6, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Remove formating
.Cells(52, c.Column).Copy
.Cells(52, c.Column).PasteSpecial _
Paste:=xlPasteValues
End If

'get current column in row 60
Set c = .Rows(60).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 60")
Else
'copy data to first emty cell below row 5/6
LastRow = .Cells(60, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(61, c.Column), _
.Cells(LastRow, c.Column))
'find last row with data below row 5/6
LastRow = .Cells(5, Row6Col).End(xlDown).Row
CopyRange.Copy
.Cells(LastRow, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Remove formating
.Cells(60, c.Column).Copy
.Cells(60, c.Column).PasteSpecial _
Paste:=xlPasteValues
End If
End If
End With
End If
Next sht
End Sub

 

[MyKey]

Joel please its not functioning right. Maybe I didn't explain well what I
wanted.
Before the code:
When I copy the column(s) and insert back; most of the information on the
columns are formula and I want the formula retained but I only want to copy
and paste certain cells as paste value and that is Cells on Row 52 and row 60.

I do Copy and Insert(not paste) on the Column(s) because I want the
column(s)pushed out while creating duplicate information. This helps cos of
formula connection of some cells to other sheets. Sorry to bother you please,
if you can help that will be totally and honorably appreciated.

Thanks

 

[MyKey]

Thanks Joel but the code is not responding as it should. I want to copy and
insert on the column(s) because I want to retain some formula in the cells
while creating duplicate columns with heading "Current" ontop, but I only
want Row 52 and Row 60 of cells under heading "Current" to be copied and
pasted as values to the old columns while leaving the formulas of others
alone.

I have posted 3 replies already but noticed that Its not showing for some
time now that is why am posting a reply again. I thot the holday is making
things slow.

Joel Thanks so much for assistant please help me through this. I totally
appreciate it.

Thanks

 

[Joel]

Tie siter has been down since the evening of the 23rd. It finally came up
this morning. I believe your original code was copying only values from all
the rows not juist rows below 50 and 6o.

I would like to know if any fot he code is working and if any of the message
boxes are appearing. You said the code isn't responding yet you said you
wanted to retain the some of the formulas . I'm not sure right now what is
working and what is not working. Can you be clearer.

 

[MyKey]

Sorry Joel, The code is working with proper naming of the sheet to TOTAL and
the messages comes up to.

However the code is not duplicating the columns (copy and insert) and I also
want to copy from the new pushed out columns of cell 52 and 62 under heading
"Current" and paste value in Cell 52 and 60 of the old column(s) not the new
column(s). I prefer the copy and insert cos of the formula that it retains
while pushing out the new column(s).

Thanks for helping me out I really appreciate this.

 

[Joel]

See if this code is better.

Sub Gettotals()

For Each sht In Sheets
If UCase(Right(sht.Name, 5)) = "TOTAL" Then
MsgBox ("Modifying sheet : " & sht.Name)
With sht
'get current column in row 5
Set c = .Rows(5).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 5")
Else
'copy data to next column
LastRow = .Cells(5, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(5, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy Destination:=c.Offset(0, 1)
'Clear out word current
c.ClearContents

Row6Col = c.Column
'get current column in row 52
Set c = .Rows(52).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 52")
Else
'copy data to row 6
LastRow = .Cells(52, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(53, c.Column), _
.Cells(LastRow, c.Column))
CopyRange.Copy
.Cells(6, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Paste Formulas in new column
CopyRange.Offset(0, 1).Paste
'Remove formating
CopyRange.PasteSpecial _
Paste:=xlPasteValues
End If

'get current column in row 60
Set c = .Rows(60).Find("Current", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find ""Current"" on sht : " & _
.Name & " row 60")
Else
'copy data to first emty cell below row 5/6
LastRow = .Cells(60, c.Column).End(xlDown).Row
Set CopyRange = .Range(.Cells(61, c.Column), _
.Cells(LastRow, c.Column))
'find last row with data below row 5/6
LastRow = .Cells(5, Row6Col).End(xlDown).Row
CopyRange.Copy
.Cells(LastRow, Row6Col).PasteSpecial _
Paste:=xlPasteValues
'Paste Formulas in new column
CopyRange.Offset(0, 1).Paste
'Remove formating
CopyRange.PasteSpecial _
Paste:=xlPasteValues
End If
End If
End With
End If
Next sht
End Sub

 

[MyKey]

It is copying and Pasting back on the next column, Some sheets have
information on the next column and its pasting right on them. I want to use
the INSERT Function not the PaSTE Function. Is this possible?

I do Copy and Insert(not paste) on the Column(s) because I want the
column(s)pushed out while creating duplicate information. This helps cos of
formula connection of some cells to other sheets. Sorry to bother you please,

Also only CELLS on Row C52 and D60 needs to be pasted back on the old
column i.e. on Cell A52 and row B60.

Is it possible that I send u a b4 and after sheet by mail. Please let me know.
I do really appreciate your effort so far. Thanks a Million

 

[Joel]

send to joel dot warburg at itt dot com

It is copying and Pasting back on the next column, Some sheets have
information on the next column and its pasting right on them. I want to use
the INSERT Function not the PaSTE Function. Is this possible?

I do Copy and Insert(not paste) on the Column(s) because I want the
column(s)pushed out while creating duplicate information. This helps cos of
formula connection of some cells to other sheets. Sorry to bother you please,

Also only CELLS on Row C52 and D60 needs to be pasted back on the old
column i.e. on Cell A52 and row B60.

Is it possible that I send u a b4 and after sheet by mail. Please let me know.
I do really appreciate your effort so far. Thanks a Million