Insert Blank Row and AutoSum Formula

**StinkBall** · 07-12-2011, 02:13 PM

In Column A, I have a list of NFL player names used multiple times like this:

Column A (Name)
Sam Jones
Sam Jones
Sam Jones
Sam Jones
Troy Smith
Troy Smith
Troy Smith
James Willis
James Willis
James Willis etc etc etc

and in Column B is a list of numbers beside each name like this:

Column A (Name) Column B (Number)
Sam Jones 6
Sam Jones 12
Sam Jones 9
Sam Jones 15
Troy Smith 18
Troy Smith 9
Troy Smith 26
James Willis 4
James Willis 25
James Willis 38

1) I need to know how to insert a blank row before each new name (i.e. add a blank row after the last Sam Jones and before the first Troy Smith and a blank row after the last Troy Smith and the first James Willis etc).

2) I need to AutoSum the numbers of Column B into the blank cell below the last entry (i.e. For Sam Jones I need =SUM( 6 +12 + 9 +15 ) where 6 is B2, 12 is B3, 9 is B4 and 15 is B5. For Troy Smith I need =SUM(18 + 9 + 26) where 18 is B7, 9 is B8 and 26 is B9. For James Willis I need =SUM(4 + 25 + 38) where 4 is B11, 25 is B12 and 38 is B13). I need this to continue down column B every time there is a blank cell under the last entry of each unique cell.

3) Also, there are other columns where I need to find the =AVG of the list of numbers in the same pattern as the above example explained in 2)

I am looking for VBA macros to automate this process for me. Thank you all in advance.

Jason

**HSV** · 07-12-2011, 04:59 PM

Something like this?
Run de code HSV on Sheet2 and see.

Sub HSV()
  Dim cl As Range, rij As Integer, rijnr As Integer, sq As Variant
    With Sheets("Sheet2")
       .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clear
      sq = "Name" & "|" & "Number " & "|"
       .Range("A1").Resize(, 2) = Split(sq, "|")
       End With
          
   With Worksheets("Sheet1")
    .Range("A2:B" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Sort .[A2], xlAscending

    For Each cl In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
      If cl > 0 Then
       With Sheets("Sheet2")
    
         .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1) = cl
        
           rij = WorksheetFunction.Match(cl, .Columns(1), 0)
           .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1).ClearContents
              rijnr = .Cells(rij, 2).CurrentRegion.Rows.Count
           
            .Cells(rij + rijnr, 1).Resize(, 2).Value = cl.Resize(, 2).Value
            .Cells(rij + rijnr + 1, 1).EntireRow.Insert
            .Cells(rij + rijnr + 2, 1) = "Totaal"
            .Cells(rij + rijnr + 2, 2).Formula = "=SUM(" & .Cells(rij, 2).Address & ":" & .Cells(rij + rijnr, 2).Address & ")"
            .Cells(rij + rijnr + 2, 2).Interior.ColorIndex = 6
          End With
       End If
      Next cl
    End With
  Sheets("Sheet2").Columns.AutoFit
End Sub

Thread: Insert Blank Row and AutoSum Formula

Thread Tools

Display

Insert Blank Row and AutoSum Formula

Re: Insert Blank Row and AutoSum Formula

Thread Information

Users Browsing this Thread

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions