Solved

VBA Code

Posted on 2011-03-07
6
207 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
  • 3
  • 2
6 Comments
 
LVL 19

Assisted Solution

by:akoster
akoster 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
Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

 

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:akoster
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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Introduction This Article is a follow-up to my Mappit! Addin Article (http://www.experts-exchange.com/A_2613.html), it was inspired by an email posting I made to EUSPRIG (http://www.eusprig.org/index.htm), I will briefly cover: 1) An overvie…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

821 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