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

unknownymous

Board Regular
Joined
Sep 19, 2017
Messages
182
Office Version
  1. 2016
Platform
  1. Windows
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:

IDRankNameScore
0011Ben100
Sam95
0022Ann92
Bea90
0033Mike45
Faye10
May25

<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

IDRankNameScore
0011Ben100
001Sam95
Total195
0022Ann92
002Bea90
Total182
0033Mike45
003May25
003Faye10
Total80
Overall TOTAL457

<tbody>
</tbody>



Any help will be much appreciated. :)
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

alansidman

Well-known Member
Joined
Feb 26, 2007
Messages
6,069
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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.
Code:
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,301
Office Version
  1. 365
Platform
  1. Windows
Another option
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,318
Messages
5,600,925
Members
414,416
Latest member
Nobu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top