# Move SUBTOTAL text one column to the right • ### Question

• Once Subtotals are run, each subtotaled row contains "Xxxxx Total" .

Need each of those "Xxxxx Total" cells in column A to be cut and pasted one cell to the right, ending up in column B.

Tried numerous variations of the following but it doesn't work ....

For Each c In Range("a120:a300")
'   If InStr((c.Value), "Total") Then
c.Cut
c.Offset(0, 1).ActiveSheet.Paste
End If
Next

Thank you in advance for any assistance.

- Mik

Thursday, May 19, 2016 1:53 PM

• That's GREAT Dominic.

Thank you ...!!

- Mik

• Marked as answer by Saturday, May 21, 2016 4:39 PM
Saturday, May 21, 2016 4:39 PM

### All replies

• Try...

```For Each c In Range("a120:a300")
If Right(c.Value, 5) = "Total" Then
c.Cut c.Offset(, 1)
End If
Next c```

Hope this helps!

Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

Friday, May 20, 2016 1:21 AM
• There are a few other things going on, will explain.

The objective is to run an overall subtotal routine that ..

- Subtotals the range.

- Makes the next visible cell below the TOTAL rows 40 chars high.

- Moves all the Xxxx Total labels one column to the right.

I inserted your sub before the following, but get an error on this line of the following code to increase row height, and the combined sub stalls:

Dim rngC As Range

Dim t As Range

Set rngC = Range("A120:A300")

Set t = rngC.Cells(1)

Set t = rngC.SpecialCells(xlCellTypeVisible).Find("Total", t, xlValues, xlPart, MatchCase:=False)

While Not t Is Nothing

Range(t.Offset(1, 0), rngC.Cells(rngC.Cells.Count + 1)).SpecialCells(xlCellTypeVisible)(1).EntireRow.RowHeight = 40

Set t = rngC.SpecialCells(xlCellTypeVisible).Find("Total", t, xlValues, xlPart, MatchCase:=False)

Wend

Also, am not using Option Explicit [I know, my bad!].

Thank you in advance for any assistance.

- Mik

Friday, May 20, 2016 2:26 AM
• >>>Once Subtotals are run, each subtotaled row contains "Xxxxx Total" .

Need each of those "Xxxxx Total" cells in column A to be cut and pasted one cell to the right, ending up in column B.<<<

According to your description, please correct me if I have any misunderstandings on your question. You could use Range.HasFormula property to detect whether cell contain formulas and use Range.Formula property to get formula, refer to below code:

```For Each c In Range("a1:a30")
If c.HasFormula And InStr(c.Formula, "TOTAL") > 0 Then
c.Cut
c.Offset(0, 1).Select         ActiveSheet.Paste
End If
Next```

Friday, May 20, 2016 2:57 AM
• Hello and thank you.

That *looks* like it should work, but does not.

Strange.

Tried it standalone, and then running thru it using f8, and no go.

- Mik

Friday, May 20, 2016 9:50 AM
• There are a few other things going on, will explain.

The objective is to run an overall subtotal routine that ..

- Subtotals the range.

- Makes the next visible cell below the TOTAL rows 40 chars high.

- Moves all the Xxxx Total labels one column to the right.

The following macro will subtotal and format the specified range.  It assumes that the sheet containing the data is the active sheet.  It also assumes that the subtotal is being added to the third column, so you'll need to change the TotalList parameter for Subtotal accordingly.  So you'll need to change this...

`TotalList:=Array(3)`

Here's the macro...

```Option Explicit

Sub SubtotalAndFormat()

Dim rData As Range
Dim rFirst As Range
Dim rLast As Range
Dim rFound As Range

Const sSearchFor As String = "Total"

If TypeName(ActiveSheet) <> "Worksheet" Then
MsgBox "No worksheet is active.", vbExclamation
Exit Sub
End If

With Application
.ScreenUpdating = False
End With

Set rData = Range("A120:A300")

On Error Resume Next
rData.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
If Err <> 0 Then
MsgBox "Unable to subtotal the specified range.", vbExclamation
GoTo ExitTheSub
End If
On Error GoTo 0

Set rFirst = rData.Cells(1)
Set rLast = Cells(Rows.Count, rFirst.Column).End(xlUp)

On Error Resume Next
With Range(rFirst, rLast)
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeConstants)(1).RowHeight = 40
Set rFound = .Find(what:="* " & sSearchFor, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not rFound Is Nothing Then
Do
rFound.Copy rFound.Offset(, 1)
rFound.Clear
If rFound.Offset(1, 0).Value <> "Grand Total" Then
Range(rFound.Offset(1, 0), rLast.Offset(2, 0)).SpecialCells(xlCellTypeConstants)(1).RowHeight = 40
End If
Set rFound = .FindNext(rFound)
Loop Until rFound Is Nothing
End If
End With
On Error GoTo 0

ExitTheSub:
With Application
.ScreenUpdating = True
End With

Set rData = Nothing
Set rFirst = Nothing
Set rLast = Nothing
Set rFound = Nothing

End Sub```

Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

Saturday, May 21, 2016 4:36 PM
• That's GREAT Dominic.

Thank you ...!!

- Mik

• Marked as answer by Saturday, May 21, 2016 4:39 PM
Saturday, May 21, 2016 4:39 PM