Urgent pls: Insert new row and sum in blank rows

[luvbite38]

Can some one kindly help me out.

I have an existing summary (see table 1) which I wish to summarise as shown in Table 2.

- I want a macro to automatically insert a row as soon the value is changed in column A (item) and than sum the total quantity of all items per category. Furthermore it should further sum the 8 (fixed types of each catergory - such as Apple will always have 8 sub catergories or Banana or any other item will always have 8 subs).

And in case if a user clicks to compile the data, I want macro to delete all newly added rows and repeat the entire process as explained above.

I hope it makes sense?

I dont know how to attach a sample file otherwise I'd have done that already........ please please please help.

************* Table 1 (existing summary page)**********
item total
apple1 1
apple2 2
apple3 2
apple5 2
apple8 9
b1 4
b8 6
grapes4 9
grapes6 11
grapes6 12
grapes6 10
grapes8 1


Kind Regards,

L
**************** Table 2 (Desired Summary Page)


apple1 1
apple2 2
apple3 2
apple5 2
apple8 9

APPLE 1 = 1 APPLE2 = 2 APPLE3 = 2 APPLE4 = 0 APPLE5 = 2 APPLE6 = 0 APPLE 7 = 0 APPLE8 = 9

b1 4
b8 6
b 1 = 4 b2 =0 b3 = 0 b4 = 0 b5 = 0 b6 = 0 b7 = 0 b8 = 6

grapes4 9
grapes6 11
grapes6 12
grapes6 10
grapes8 1
grapes 1 = 0 grapes2 = 0 grapes3 = 0 grapes4 = 9 grapes5 = 0 grapes6 = 33 grapes 7 = 0 grapes8 = 1

 

[jbeaucaire]

Excel Workbook
	A	B
1	item	total
2	apple1	1
3	apple2	2
4	apple3	2
5	apple5	2
6	apple8	9
7	b1	4
8	b8	6
9	grapes4	9
10	grapes6	11
11	grapes6	12
12	grapes6	10
13	grapes8	1
BEFORE

Excel Workbook
	A	B
1	item	total
2	apple1	1
3	apple2	2
4	apple3	2
5	apple5	2
6	apple8	9
7
8	Total	16
9
10	b1	4
11	b8	6
12
13	Total	10
14
15	grapes4	9
16	grapes6	11
17	grapes6	12
18	grapes6	10
19	grapes8	1
20
21	Total	43
AFTER

Option Explicit

Sub AddSubtotals()
Dim Rw As Long, FR As Long

Rw = 2  'starting row
FR = Rw
Do
    If LettersOnly(Range("A" & Rw)) <> LettersOnly(Range("A" & Rw + 1)) Then
        Rows(Rw + 1).Resize(3).EntireRow.Insert xlShiftDown
        Range("A" & Rw + 2) = "Total"
        Range("B" & Rw + 2).FormulaR1C1 = "=SUM(R" & FR & "C:R" & Rw & "C)"
        Rw = Rw + 4
        FR = Rw
    Else
        Rw = Rw + 1
    End If
Loop Until Range("A" & Rw) = ""

End Sub


Function LettersOnly(txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "[^A-Z\s]+"      'leaves only letters and spaces
        .Global = True
        .IgnoreCase = True
        LettersOnly = Application.WorksheetFunction.Trim(.Replace(txt, ""))
    End With
End Function

 

[luvbite38]

Thanks a million mate........ thank you