excel vba Is it possible to auto sum and add to vba created header?

[cizzett]

So I have this sheet that automatically seperates the data byt column D value then uses that value to create a formatted "Header" for each group and places the name from D into the newly created header. My question is is it possible to add the sum of G in the header as well?

Heres my code

Sub IRIPS()     
   Dim lRow As Long
   For lRow = Cells(Cells.Rows.Count, "E").End(xlUp).Row To 3 Step -1
      If Cells(lRow, "E") <> Cells(lRow - 1, "E") Then
         With Cells(lRow, 1).Resize(, 7)
            .Insert xlDown
            With .Offset(-1)
               .MergeCells = True
               .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
               .Value = Cells(lRow + 1, "E") & "- "
               .Interior.ThemeColor = xlThemeColorLight1
               With .Font
                  .Name = "3M Circular TT Bold"
                  .Size = 12
                  .ThemeColor = xlThemeColorDark1
               End With
            End With
         End With
      End If
   Next lRow
    
End Sub

This is what it looks like after running and what I would like it to look like:
https://www.dropbox.com/s/p3ug067dt0...Test.xlsm?dl=0

 

[mumps]

Try:

Sub CreateHeader()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, key As Variant, fVis As Long, tot As Long
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("D2", Range("D" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each key In RngList
        With Range("A1").CurrentRegion
            .AutoFilter 4, key
            fVis = Range("D2", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
            tot = WorksheetFunction.Sum(Range("G2", Cells(Rows.Count, "G").End(xlUp)).SpecialCells(xlCellTypeVisible))
            Rows(fVis).Insert
            Cells(fVis, 1) = key & "-" & tot
            With Range("A" & fVis & ":J" & fVis)
                .HorizontalAlignment = xlCenterAcrossSelection
                .VerticalAlignment = xlCenter
                .Interior.ThemeColor = xlThemeColorLight1
                With .Font
                  .Name = "3M Circular TT Bold"
                  .Size = 12
                  .ThemeColor = xlThemeColorDark1
               End With
            End With
        End With
    Next key
    Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[cizzett]

Works perfect Mumps!!!!!

Thanks you crazy mad genius, your'e awesome.

 

[mumps]

You are very welcome. :

 

[cizzett]

Hey Mumps, this works great except..... this puts the info for each category over the row but not actually in the row. If I try to copy and paste it into outlook then it crashes because it is not an actual cell value.

Second issue I ran into is if I do not use a table(So I can have the row merged for the data) then it puts all the new rows all at the top in row 1, 2, 3, etc..

I have been trying to mess with it to get it to work but not sure.

 

[cizzett]

here is an example of the workbook the way I want it to come out.

https://www.dropbox.com/s/1l3a1jisgcfx0hm/SG trial.xltm?dl=0

The original code worked perfectly it just didn't add the totals for each set, not sure if it can really be done this way or not.<o></o>

 

[mumps]

See if this works for you:

Sub IRCV()
   Application.ScreenUpdating = False
   Application.EnableEvents = False
    Dim Rng As Range, RngList As Object, key As Variant, fVis As Long, tot As Long
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("D10", Range("D" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each key In RngList
        ActiveSheet.ListObjects("SteriTable").Range.AutoFilter Field:=4, Criteria1:=key
        fVis = Range("D10", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
        tot = WorksheetFunction.Sum(Range("G10", Cells(Rows.Count, "G").End(xlUp)).SpecialCells(xlCellTypeVisible))
        Rows(fVis).Insert
        With Range("A" & fVis & ":K" & fVis)
            .ClearContents
            .RowHeight = 15
            .HorizontalAlignment = xlCenterAcrossSelection
            .VerticalAlignment = xlCenter
            .Interior.ThemeColor = xlThemeColorLight1
            With .Font
              .Name = "3M Circular TT Bold"
              .Size = 12
              .ThemeColor = xlThemeColorDark1
           End With
        End With
        Cells(fVis, 1) = key & "-" & tot
    Next key
    Range("D10").AutoFilter
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Rows(2).RowHeight = 15.75
End Sub

 

[cizzett]

So I wound up adding a helper column on the main sheet that counts the loads and then use that to insert the value into the header using the below code.

Thanks so much for the help though, I always appreciate it.

Heres my solution:

Sub IRIPS()    
    Call DeleteRows
    Call Intl_Sort
    Application.CutCopyMode = False
    
   Dim lRow As Long
   Dim CCnum As String
     
   For lRow = Cells(Cells.Rows.Count, "E").End(xlUp).Row To 3 Step -1
      
      If Cells(lRow, "E") <> Cells(lRow - 1, "E") Then
         With Cells(lRow, 1).Resize(, 7)
            .Insert xlDown
            With .Offset(-1)
               .MergeCells = True
                 .HorizontalAlignment = xlCenter
                 .VerticalAlignment = xlBottom
                On Error Resume Next
                   CCnum = Application.WorksheetFunction.VLookup(Cells(lRow + 1, "E"), _
                     Sheets("Steri Sheet").Range("O2:P8"), 2, False)
                     
                .Value = Cells(lRow + 1, "E") & " - " & CCnum
               .Interior.ThemeColor = xlThemeColorLight1
               With .Font
                  .Name = "3M Circular TT Bold"
                  .Size = 12
                  .ThemeColor = xlThemeColorDark1
               End With
            End With
         End With
      End If
   Next lRow
   
    Rows(3).RowHeight = 15
    Range("A3").Select
    
End Sub

 

[mumps]

Glad it worked out.