• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Subtotal macro for numbers only

R

RAM72

Member
Hi All

Am concatenating cells through a macro but have an issue as below when doing subtotals by headers .

Can this be done to add only the first digits
Code: 
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA Total

Expected results


Code: 
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (1*6*750 ML) ZA
22042190 WINES (8*6*750 ML) ZA Total
 
jindon said:
Are they in one cell?

Uploading workbook will help.
Click to expand...

Hi
Apologize for late reply I was figuring how to present the data

See annexed column L,Q,R,S and Y

Actual using Subtotal but having a drawback that is it total one by one on the actual sheet.

I d'ont know if this is achievable in vba .

Hope it helps
 

Attachments

  • sub total sample.xlsx
    53.5 KB · Views: 12
See if this is how you wanted.
Check the data in Col.J first.
Some are missing closing bracket etc.
If the data is not accurate, the code will not work as expected.
Code: 
Sub test()
    Dim r As Range, temp As String
    Application.ScreenUpdating = False
    With Sheets("sorted workings")
        With .Cells(1).CurrentRegion
            With .Columns("ab").Offset(2).Resize(.Rows.Count - 2)
                .EntireRow.Font.Bold = False
                .Formula = "=if(and(right(l2,5)<>""Total"",right(l3,5)<>""Total"",replace(l2,find(""("",l2&""(""),sum(find({"")"",""(""},l2&""()"")*" & _
                "{1,-1})+1,"""")<>replace(l3,find(""("",l3&""(""),sum(find({"")"",""(""},l3&""()"")*{1,-1})+1,"""")),if(ab2=1,""a"",1),"""")"
                .Value = .Value
                On Error Resume Next
                .SpecialCells(2, 1).EntireRow.Insert
                .SpecialCells(2, 2).EntireRow.Insert
                On Error GoTo 0
                .EntireColumn.ClearContents
            End With
        End With
        For Each r In .Columns("i").SpecialCells(2, 1).Areas
            temp = r(1, 4).Value
            If (r.Count > 1) * (temp Like "*(#*") Then
                temp = GetTotal(r.Offset(, 3))
            End If
            r(r.Count + 1, 1).EntireRow.Range("a1:aa1").Font.Bold = True
            r(r.Count + 1, 4).Value = temp & " Total"
            r(r.Count + 1, 9).Resize(, 3) = "=subtotal(9," & r.Offset(, 8).Address(0, 0) & ")"
            r(r.Count + 1, 17) = "=subtotal(9," & r.Offset(, 16).Address(0, 0) & ")"
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Function GetTotal(ByVal rng As Range) As String
    Dim a, i As Long, myTotal As Long
    a = rng.Value
    With CreateObject("VBScript.RegExp")
        .Pattern = "\((\d+)(.*?\))"
        For i = 1 To UBound(a, 1)
            If .test(a(i, 1)) Then
                myTotal = myTotal + Val(.Execute(a(i, 1))(0).submatches(0))
                GetTotal = .Replace(a(i, 1), "(" & myTotal & "$2")
            End If
        Next
    End With
End Function
 
jindon said:
See if this is how you wanted.
Check the data in Col.J first.
Some are missing closing bracket etc.
If the data is not accurate, the code will not work as expected.
Code: 
Sub test()
    Dim r As Range, temp As String
    Application.ScreenUpdating = False
    With Sheets("sorted workings")
        With .Cells(1).CurrentRegion
            With .Columns("ab").Offset(2).Resize(.Rows.Count - 2)
                .EntireRow.Font.Bold = False
                .Formula = "=if(and(right(l2,5)<>""Total"",right(l3,5)<>""Total"",replace(l2,find(""("",l2&""(""),sum(find({"")"",""(""},l2&""()"")*" & _
                "{1,-1})+1,"""")<>replace(l3,find(""("",l3&""(""),sum(find({"")"",""(""},l3&""()"")*{1,-1})+1,"""")),if(ab2=1,""a"",1),"""")"
                .Value = .Value
                On Error Resume Next
                .SpecialCells(2, 1).EntireRow.Insert
                .SpecialCells(2, 2).EntireRow.Insert
                On Error GoTo 0
                .EntireColumn.ClearContents
            End With
        End With
        For Each r In .Columns("i").SpecialCells(2, 1).Areas
            temp = r(1, 4).Value
            If (r.Count > 1) * (temp Like "*(#*") Then
                temp = GetTotal(r.Offset(, 3))
            End If
            r(r.Count + 1, 1).EntireRow.Range("a1:aa1").Font.Bold = True
            r(r.Count + 1, 4).Value = temp & " Total"
            r(r.Count + 1, 9).Resize(, 3) = "=subtotal(9," & r.Offset(, 8).Address(0, 0) & ")"
            r(r.Count + 1, 17) = "=subtotal(9," & r.Offset(, 16).Address(0, 0) & ")"
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Function GetTotal(ByVal rng As Range) As String
    Dim a, i As Long, myTotal As Long
    a = rng.Value
    With CreateObject("VBScript.RegExp")
        .Pattern = "\((\d+)(.*?\))"
        For i = 1 To UBound(a, 1)
            If .test(a(i, 1)) Then
                myTotal = myTotal + Val(.Execute(a(i, 1))(0).submatches(0))
                GetTotal = .Replace(a(i, 1), "(" & myTotal & "$2")
            End If
        Next
    End With
End Function
Click to expand...

Thanks for your valuable assistances Jindon
Your coding is :awesome::awesome:
Working as champ :):cool:

Sorry for late reply was off for some week due overstress work.
 
You must log in or register to reply here.
Back
Top