Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 218
  • Last Modified:

VBA Code

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
Seamus2626
Asked:
Seamus2626
  • 3
  • 2
2 Solutions
 
Arno KosterCommented:
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
 
SiddharthRoutCommented:
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
 
SiddharthRoutCommented:
Sorry akoster. Didn't see your post.

Sid
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Seamus2626Author Commented:
Thanks guys, i was playing with your code Akoster, but Sids slotted straight in, hence the uneven split.

Thanks again guys
Seamus
0
 
Arno KosterCommented:
Sid,

no problem, it happens to everyone once in a while...
0
 
SiddharthRoutCommented:
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

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now