none
Move SUBTOTAL text one column to the right RRS feed

  • 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

Answers

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:

         strAdd = t.Address

    Dim rngC As Range

         Dim t As Range

         Dim strAdd As String

         Set rngC = Range("A120:A300")

         Set t = rngC.Cells(1)

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

         strAdd = t.Address

         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)

             If t.Address = strAdd Then Exit Sub

         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

    For more information, click here to refer about Range.HasFormula Property and here to refer about Range.Formula Property

    In addition could you provide more information about your issue, for example screenshot, that will help us reproduce and resolve it.

    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
            .DisplayAlerts = False
            .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
            .DisplayAlerts = True
            .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 Mikf Saturday, May 21, 2016 4:39 PM
    Saturday, May 21, 2016 4:39 PM