VBA code to rearrange data

[KP_SoCal]

The block of code below, provided to me by Peter SSs, needs to be modified slightly to accomplish a new task.

Instead of just grouping and offsetting the given values in my range for column A, I need to do something similar for a range in column B with a small exception. The offset target should be at the bottom of the group as opposed to the top of the group. Also the text “Total” should be concatenated to the value of the CLASS group. In the event there is no value for CLASS listed, “Total” should be listed at the bottom of the Null class group.

The screen shot below better illustrates what I’m trying to accomplish. Notice where I have borders inserted as well, and notice how each group is being summed.

Any possible solutions are appreciated more than you could possibly image. Thanks!

KP

Sub Rearrange()
    Dim Aarea As Range, Arange As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Arange = Range("A10", Range("A" & Rows.Count).End(xlUp))
    With Arange
        .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents
        .Offset(, -1).EntireColumn.Delete
        .EntireColumn.RemoveSubtotal
    End With
    For Each Aarea In Arange.SpecialCells(xlCellTypeConstants).Areas
        With Aarea
            With .Cells(1, 1).Offset(-1)
                .Value = .Offset(1).Value
                .Font.Bold = True
                .EntireRow.Insert
            End With
            .ClearContents
        End With
    Next Aarea
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[hiker95]

KP_SoCal,

You are posting a picture. This means that if this was a problem where one needed to use your data, anyone trying to help you would have to enter the data manually. That makes no sense and I doubt you'd get any answer.

Please post a screenshot of your sheet(s), what you have and what you expect to achieve, with Excel Jeanie HTML 4 (contains graphic instructions).
http://www.excel-jeanie-html.de/html/hlp_schnell_en.php

Or, you can upload your workbook to www.box.net and provide us with a link to your workbook.

 

[MickG]

Hi, Try this, Results sheet (2).

[COLOR="Navy"]Sub[/COLOR] MG26Jul46
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, A [COLOR="Navy"]As[/COLOR] Range, Suba [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Y [COLOR="Navy"]As[/COLOR] Double, M [COLOR="Navy"]As[/COLOR] Double, W [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A6"), Range("A" & Rows.Count).End(xlUp))
    ReDim Ray(1 To Rng.Count * 2, 1 To 5)
        Lst = Range("A" & Rows.Count).End(xlUp).Row
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn & Dn(, 2) <> Temp And Temp = "" [COLOR="Navy"]Then[/COLOR]
        Txt = Txt & Dn.Address & ":"
        Temp = Dn & Dn(, 2)
    [COLOR="Navy"]ElseIf[/COLOR] Dn & Dn(, 2) <> Temp [COLOR="Navy"]Then[/COLOR]
        Txt = Txt & Dn.Offset(-1).Address & "," & Dn.Address & ":"
        Temp = Dn & Dn(, 2)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Txt = Txt & Range("A" & Lst).Address
[COLOR="Navy"]Set[/COLOR] Rng = Range(Txt)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] A [COLOR="Navy"]In[/COLOR] Rng.Areas
    n = n + 1
    Ray(n, 1) = A(1): Ray(n, 3) = "Year Total": Ray(n, 4) = "Month Total": Ray(n, 5) = "Week Total"
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Suba [COLOR="Navy"]In[/COLOR] A
        n = n + 1
        Ray(n, 1) = Suba.Offset(, 2): Ray(n, 2) = Suba.Offset(, 3): Ray(n, 3) = Suba.Offset(, 4): Ray(n, 4) = Suba.Offset(, 5): Ray(n, 5) = Suba.Offset(, 6)
        Y = Y + Suba.Offset(, 4)
        M = M + Suba.Offset(, 5)
        W = W + Suba.Offset(, 6)
[COLOR="Navy"]Next[/COLOR] Suba
    n = n + 1
    Ray(n, 2) = "Total" & A(1).Offset(, 1): Ray(n, 3) = Y: Ray(n, 4) = M: Ray(n, 5) = W
    Y = 0: M = 0: W = 0
[COLOR="Navy"]Next[/COLOR] A
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Range("a1").Resize(n, 5) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[KP_SoCal]

hiker95,
Thanks for both of these resource full links. I can utilize these for future posts. Good stuff!

MickG,
Your code accomplished what I needed. Thank you so much!!!

 

[MickG]

Hi, Glad to be of help .
Just a thought, if you add a n= n +1 to the bottom of the code, as shown below , you will get a Blank line between each set of data.

Next Suba
    n = n + 1
    Ray(n, 2) = "Total" & A(1).Offset(, 1): Ray(n, 3) = Y: Ray(n, 4) = M: Ray(n, 5) = W
    Y = 0: M = 0: W = 0
    n = n + 1
Next A

Regards Mick

 

[KP_SoCal]

Mick, even more great stuff! Thanks again!!!

KP