Solved

VBA Code

Posted on 2011-03-07
6
210 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
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 

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

Industry Leaders: 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!

Question has a verified solution.

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

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.
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
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…

717 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