Insetr Text and SubTotal/Autosum

[Zibi]

Hi,

Can Someone help me with the VBA? I have code but i dont know how to change to insert Text and then Total.



Sub Test()
Dim Rng As Range
Dim x As Long


Set Rng = Range("F1:F" & Range("F65536").End(xlUp).Row)
For x = Rng.Rows.Count To 2 Step -1
If Rng.Cells(x, 1).Offset(-1, 0).Value <> Rng.Cells(x, 1).Value Then

'insert Text "TOTAL"


Rng.Cells(x, 1).EntireRow.Insert Shift:=xlDown


'insert AutoSUM formula next to "TOTAL"

Rng.Cells(x, 1).EntireRow.Insert Shift:=xlDown
Rng.Cells(x, 1).EntireRow.Insert Shift:=xlDown

End If
Next x
End Sub

Apple	3
Apple
Apple	4
Apple
Apple
Total	7
Orange
Orange	3
Orange
Orange
Total	3
Cheese	9
Cheese
Cheese	3
Total	12

<TBODY>
</TBODY>

 

[hiker95]

Zibi,

Your text display shows inserting three rows?

Sample raw data:

Excel 2007
	F	G
1	Apple	3
2	Apple
3	Apple	4
4	Apple
5	Apple
6	Orange
7	Orange	3
8	Orange
9	Orange
10	Cheese	9
11	Cheese
12	Cheese	3
13
14
15
16
17
18
19
20
Sheet1

After the macro:

Excel 2007
	F	G
1	Apple	3
2	Apple
3	Apple	4
4	Apple
5	Apple
6	Total	7
7
8
9	Orange
10	Orange	3
11	Orange
12	Orange
13	Total	3
14
15
16	Cheese	9
17	Cheese
18	Cheese	3
19	Total	12
20
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData()
' hiker95 05/29/2014, ME780943
Dim r As Long, lr As Long
Dim Area As Range, sr As Long, er As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
For r = lr To 2 Step -1
  If Cells(r - 1, 6) <> Cells(r, 6) Then
    Rows(r).Resize(3).Insert
  End If
Next r
For Each Area In Range("F1", Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    With Cells(er + 1, 6)
      .Value = "Total"
      .Font.Bold = True
    End With
    Cells(.Row + .Rows.Count, 7).Value = Evaluate("=Sum(G" & .Row & ":G" & .Row + .Rows.Count - 1 & ")")
  End With
Next Area
Columns("F:G").AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[hiker95]

Zibi,

Here is a version of the macro that will insert two rows.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgDataV2()
' hiker95 05/29/2014, ME780943
Dim r As Long, lr As Long
Dim Area As Range, sr As Long, er As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
For r = lr To 2 Step -1
  If Cells(r - 1, 6) <> Cells(r, 6) Then
    Rows(r).Resize(2).Insert
  End If
Next r
For Each Area In Range("F1", Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    With Cells(er + 1, 6)
      .Value = "Total"
      .Font.Bold = True
    End With
    Cells(.Row + .Rows.Count, 7).Value = Evaluate("=Sum(G" & .Row & ":G" & .Row + .Rows.Count - 1 & ")")
  End With
Next Area
Columns("F:G").AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV2 macro.


Just let me know if you want to see the actual formulae in the correct cell?

 

[hiker95]

Zibi,

Here is a version that will insert the SUM formulae.

After the macro:

Excel 2007
	F	G
1	Apple	3
2	Apple
3	Apple	4
4	Apple
5	Apple
6	Total	7
7
8	Orange
9	Orange	3
10	Orange
11	Orange
12	Total	3
13
14	Cheese	9
15	Cheese
16	Cheese	3
17	Total	12
18
Sheet1

Cell Formulas
Range	Formula
G6	=SUM(G1:G5)
G12	=SUM(G8:G11)
G17	=SUM(G14:G16)

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgDataV3()
' hiker95 05/29/2014, ME780943
Dim r As Long, lr As Long
Dim Area As Range, sr As Long, er As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
For r = lr To 2 Step -1
  If Cells(r - 1, 6) <> Cells(r, 6) Then
    Rows(r).Resize(2).Insert
  End If
Next r
For Each Area In Range("F1", Range("F" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    With Cells(er + 1, 6)
      .Value = "Total"
      .Font.Bold = True
    End With
    Cells(.Row + .Rows.Count, 7).Formula = "=Sum(G" & .Row & ":G" & .Row + .Rows.Count - 1 & ")"
  End With
Next Area
Columns("F:G").AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV3 macro.

 

[Zibi]

Thanks for help, these codes work like a charm.

 

[hiker95]

Zibi,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.