Solved

VBA Code

Posted on 2011-03-07
6
209 Views
Last Modified: 2012-06-27
Hi,

I have a spreadsheet where i would like

(1) Read colF, when ever a number is not identical to the onle above it, add two rows and sum the columns for a subtotal. Bold the Subtotal

(2) Sum the columns of E as well

I have attached the raw data file (example) and a file which is where i want to be afterwards with the subtotals (example2), does anyone know any code that could do this?

Thanks
Seamus
Example.xls
Example2.xls
0
Comment
Question by:Seamus2626
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
6 Comments
 
LVL 19

Assisted Solution

by:Arno Koster
Arno Koster earned 150 total points
ID: 35057295
Seamus,

when you record the steps you make when going from example.xls to example2.xls, you will be presented with a rough macro that performs the trick.
Later on, you could clean up the code.

eg: the recorded code for including subtotals
Sub insert_subtotals()
'
' insert_subtotals Macro
'

'
    Columns("A:F").Select
    Range("F1").Activate
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Open in new window


can be rewritten to
Sub insert_subtotals()
    Columns("A:F").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Open in new window


In order to add additional rows append some code, leading to :

Sub insert_subtotals()

    '-- add sub totals
    Columns("A:F").Subtotal GroupBy:=6, Function:=xlSum, TotalList:=Array(6), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    
    '-- add spacers
    For Each Row In UsedRange.Columns("A:F").Rows
        If Left(Row.Cells(5), 3) = "Tot" Then
            Rows(Row.Row + 1).Insert shift:=xlShiftDown
        End If
    Next Row
    
End Sub

Open in new window

0
 
LVL 30

Accepted Solution

by:
SiddharthRout earned 350 total points
ID: 35057363
Try this

Sub Sample()
    Dim TotColumns()
    Dim I As Long, LastRow As Long
    
    FinalCol = Sheets("Details").Range("A1").End(xlToRight).Column
    
    Application.ScreenUpdating = False
    
    ReDim Preserve TotColumns(1 To FinalCol - 2)
    For I = 3 To FinalCol
        TotColumns(I - 2) = I
    Next I
    
    With Sheets("Details")
        .Range("A1").Subtotal GroupBy:=6, Function:=xlSum, TotalList:=TotColumns, _
        Replace:=True, PageBreaks:=True, SummaryBelowData:=True
    
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
    
        For I = LastRow To 1 Step -1
            If InStr(1, .Range("B" & I).Value, "Total", vbTextCompare) Then
                .Range("F" & I).Font.Bold = True
                .Range("F" & I).Value = Format(Range("F" & I).Value, "#,##0.00000000") & " Total"
                .Range("C" & I).Copy Range("B" & I)
                
                .Rows(I + 1).Select
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next I
    End With
    Application.ScreenUpdating = True
End Sub

Open in new window


Sid
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35057368
Sorry akoster. Didn't see your post.

Sid
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Closing Comment

by:Seamus2626
ID: 35057419
Thanks guys, i was playing with your code Akoster, but Sids slotted straight in, hence the uneven split.

Thanks again guys
Seamus
0
 
LVL 19

Expert Comment

by:Arno Koster
ID: 35058926
Sid,

no problem, it happens to everyone once in a while...
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35058963
Thanks. I had refreshed the page and then I started working on the file, testing each line of the code to ensure it worked exactly as the OP wanted and maybe that is the reason why there was a gap.

Sid
0

Featured Post

SharePoint Admin?

Enable Your Employees To Focus On The Core With Intuitive Onscreen Guidance That is With You At The Moment of Need.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

732 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question