Only Copy Subtotals

[Stephen]

Hi Folks,

I have a sheet (Receives) that generates a dataset based on date parameters
from a different sheet (Date Selection), then subtotals column "E" of the
dataset at each change in column "A". That works like a charm.

I need to be able to copy only the subtotal rows to a third sheet but I
would like those copied rows to paste sequentially to row 1,2,3, etc. - does
that make sence?

Here is what I have so far...

Sub Receives()

ThisWorkbook.Worksheets("Receives").Select
Range("A2").Select
Selection.RemoveSubtotal

Range("A1").Select
Selection.QueryTable.Refresh BackgroundQuery:=False

Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

ActiveSheet.Outline.ShowLevels RowLevels:=2
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Font.Bold = False
Selection.Font.Bold = True
ActiveSheet.Outline.ShowLevels RowLevels:=3

Columns("A:A").EntireColumn.AutoFit
Range("A1").Select

MsgBox "Operation completed successfully."

End Sub

I would like to have code prior to the Msgbox that would copy subtotals to
sheet three.

TIA!

 

[FSt1]

hi,
how is your data layed out? Post 4 or 5 lines or enough to subtotal on.
need something to key on.

regards
FSt1

 

[Stephen]

I think I found my answer...

ActiveSheet.Outline.ShowLevels RowLevels:=2
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Selection.Copy
Sheets("Totals").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("D:G").Delete
Range("A1").Select

ThisWorkbook.Worksheets("Receives").Select
ActiveSheet.Outline.ShowLevels RowLevels:=3

Columns("A:A").EntireColumn.AutoFit
Range("A1").Select

MsgBox "Operation completed successfully."

This seems to work fine. BUT I realized that column "B" is blank on these
subtotal rows. Is there a way I can 'copy values to empty cells below filled
cells in selection' before I copy them to the 'Totals' sheet?? I know this
is a function that is included in ASAP Utilities, but I would like to
incorporate this function into my macro.

???

 

[FSt1]

hi
i wrote a sub to copy the sub totals but it keys on my data. i was wanted to
key it to your data. works pretty good. the if statement below keys on my
data. you will need to change it to fit your data. post back if you have
problems.

Sub copysubtotals()
Dim r As Range
Dim rd As Range
Set r = Range("B2")
Do While Not IsEmpty(r)
Set rd = r.Offset(1, 0)
If r.Offset(0, -1).Value = "" Then
Range(r, r.Offset(0, 3)).Copy
Sheets("Sheet3").Range("A65000").End(xlUp). _
Offset(1, 0).PasteSpecial xlPasteValues
End If
Set r = rd
Loop
End Sub

regards
FSt1

 

[Stephen]

I appreciate your code and may very very use it, but I've thought of a
different approach...
If I subtotal on column "B", I can copy the correct values, clean the pasted
data (delete useless columns and header row), and trim the last 6 characters
to remove the word "Total" from my result set...

Once I have my subtotals copied to my totals sheet and clean the columns...

ActiveSheet.Outline.ShowLevels RowLevels:=2
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Selection.Copy
Sheets("Totals").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=True, Transpose:=False
Range("F:I").Delete
Range("C").Delete
Range("A:A").Delete
Range("1:1").Delete

....I need to figure out my last row in column "A", the trim the last 6
characters from each cell. Something like...

Dim c As Range
With Sheets("Totals")
For Each c In .Range("A:A")
c.Value = Right(c, 6)
Next
End With

???

 

[FSt1]

hi
not sure but the trim function seems like it would work but you deleted
column A before you got to it. or did i miss something?
test it. use it if it works.

Regards
FSt1

 

[Stephen]

Trim results in deleting everything except the last six characters.

when I delete my column "A", my column "B" becomes my new column "A" which
is where I need to remove the last six characters from each used cell.

LEN??

 

[FSt1]

hi
now that i think about it. the trim function just trims leading and
trailing spaces.
len.... that will just give the the length of characters in a string.
last 6 characters....right(A1,6)

regards
FSt1

 

[Jenny Barker]

What about:

Columns("A:A").Select
Selection.Replace What:=" Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False