Insert Blank Rows between sorted projects, Subtotal project to the right of final project.

[ZAC7]

Hello Excel People,

I am new to VBA and creating Macros. What I am looking for is a macro to insert 1 blank row between each unique ungrouped project set. Also I need to subtotal each project to the right of the last entry for each project. Most project have thousands of rows and I am forced to manually insert blank rows, consuming a lot of uneccesary time. Here is a simple example of the desired effect, before and after.

Please Login or Register  to view this content.

[Kelshaer]

Try this

Please Login or Register  to view this content.

[ZAC7]

Kelshaer, thanks for your contribution. It worked perfectly. Seemed simple too. Any advice on where to begin with learning to write simple codes likes this? I'd like to contribute and not just leech off the forums.

[Kelshaer]

I will send you a PM.
Just please mark this Thread as SOLVED

[Cutter]

@ ZAC7

Based on your last post it seems that you are satisfied with the solution(s) you've received but you haven't marked your thread as SOLVED. I'll do that for you now but please keep in mind for your future threads that Rule #9 requires you to do that yourself. If your problem has not been solved you can use Thread Tools (located above your first post) and choose "Mark this thread as unsolved".
Thanks.

Also, as a relatively new member of the forum, you may not be aware that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post in which the help was given. By doing so you can add to the reputation(s) of those who helped.

[ZAC7]

Thanks for the info. Cutter. Yes I am new to the forum and I will happily abide by the forum rules. Pardon my temporary ignorance. I think the forum is great and will review the rules and guidelines carefully from now on. Besides that, any tips such as those you gave recently are much appreciated!

[Sa DQ]

Sub InsertBlanlRowWithToTal() 
 Dim Rws As Long, wW As Long, ToTal As Double, zZ As Long 
 Dim Cls As Range 
  
 Columns("H:H").Insert Shift:=xlToRight 
 Rws = Cells(Cells.Rows.Count, "B").End(xlUp).Row 
  
 ReDim Arr(1 To 2 * Rws, 1 To 2):               ReDim ATmp(2 To Rws + 1) 
  
 ATmp() = Range("B2:B" & Rws + 1).Value: 
 Arr(1, 1) = "Project ToTal":                   Arr(1, 2) = "GPE.COM" 
 Arr(Rws + 1, 2) = "A01" 
 For wW = 2 To Rws 
    Arr(wW, 2) = "A" & zZ 
    ToTal = ToTal + Cells(wW, "F").Value 
    If ATmp(wW - 1, 1) <> ATmp(wW, 1) And ATmp(wW, 1) <> "" Then 
        zZ = zZ + 1 
        Arr(1 + Rws + zZ, 2) = "A" & zZ & zZ:   Arr(wW, 1) = ToTal 
        ToTal = 0 
    End If 
GPE: 
 Next wW 
 [h1].Resize(2 * Rws, 2).Value = Arr() 
 [h1].CurrentRegion.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=xlGuess, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 
 Columns("I:I").ClearContents 
End Sub  

AddBlankRow.jpg