VBA Excel Add Column In Each Column, Copy the Criteria and Add Total

[unknownymous]

Hi Guys,

I have this project in mind but don't know how to execute it. Could you possibly help me on the coding for below:

Before:

ID	Rank	Name	Score
001	1	Ben	100
		Sam	95
002	2	Ann	92
		Bea	90
003	3	Mike	45
		Faye	10
		May	25

<tbody>
</tbody>

After:

*ID number will be copied to those name within the rank
*There's a TOTAL Score formula for every Rank
*Score for must be in descending form
*There is 1 blank column per each rank after the Total
*Create Overall TOTAL Score

ID	Rank	Name	Score
001	1	Ben	100
001		Sam	95
	Total		195
002	2	Ann	92
002		Bea	90
	Total		182
003	3	Mike	45
003		May	25
003		Faye	10
	Total		80
	Overall TOTAL		457

<tbody>
</tbody>

Any help will be much appreciated.

 

[alansidman]

Here's a starting macro for you. I don't have time to complete right now. Will check back later to see if someone else has completed and if not, will continue.

Option Explicit
Sub unknown()
Dim lr As Long, i As Long
lr = Range("c" & Rows.Count).End(xlUp).Row
For i = 2 To lr
If Range("A" & i) = "" Then
Range("A" & i) = Range("A" & i - 1)
End If
Next i


For i = lr To 3 Step -1
If Range("A" & i) <> Range("A" & i - 1) Then
Range("A" & i).EntireRow.Insert
End If
Next i


For i = 2 To lr
If Range("A" & i) = "" Then Range("A" & i) = "Total"
Next i


For i = lr To 2 Step -1
If Range("A" & i) = "Total" Then Range("A" & i + 1).EntireRow.Insert
Next i






End Sub

 

[unknownymous]

Cool! Will wait for the rest of it then..

 

[Fluff]

Another option

Sub InsertTotals()

   Dim Rng As Range
   Dim UsdRws As Long
   
   With Range("A3:A" & Range("C" & Rows.Count).End(xlUp).Row)
      .SpecialCells(xlConstants).EntireRow.Insert
      .SpecialCells(xlConstants).EntireRow.Insert
   End With
   
   With Range("C2", Range("C" & Rows.Count).End(xlUp))
      For Each Rng In .SpecialCells(xlConstants).Areas
         Rng.Offset(, -2).FillDown
         Rng.Offset(Rng.Count).Offset(, -1).Resize(1).Value = "Total"
         With Rng.Offset(Rng.Count, 1).Resize(1)
            .Formula = "=sum(" & Rng.Offset(, 1).Address(False, False) & ")"
         End With
      Next Rng
   End With
   
   UsdRws = Range("D" & Rows.Count).End(xlUp).Row
   With Range("B" & UsdRws).Offset(2)
      .Value = "Overall Total"
      .Offset(, 2).Formula = "=sum(" & Range("D2:D" & UsdRws + 1).SpecialCells(xlBlanks).Offset(-1).Address & ")"
   End With
End Sub