Re: Aggregating Monthly Tabs - Variable # of Rows
Hi ekfasy
The attached file has a Dynamic Named Range in Sheet "Lists" titled "Sales_Persons". Please make certain ALL your Sale Persons are included on that list and that the Spelling of the names is consistent throughout the Workbook.
The Code relies on this Named Range to go through each Monthly report to extract the records of each Sales Person and accumulates the persons records to YTD.
This Code is in the File...CTRL + x will fire the Code.
Option Explicit
Sub Add_Stuff()
Dim rFoundCell As Range
Dim myRegion As String
Dim myStart As String
Dim myEnd As String
Dim myEndCol As String
Dim myStartRow As String
Dim myEndRow As String
Dim cel As Range
Dim ws As Worksheet
Dim lrYTD As Long
Dim nmYTD As Long
Application.ScreenUpdating = False
Sheets("YTD").UsedRange.Offset(1, 0).Clear
For Each cel In Range("Sales_Persons")
With Sheets("YTD")
nmYTD = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
.Range("A" & nmYTD + 1).Value = cel.Value
End With
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = "YTD" And Not ws.Name = "Lists" Then
Set rFoundCell = ws.Cells(2, 1)
ws.Range("A2").EntireRow.Insert
Set rFoundCell = ws.Columns(1).Find(What:=cel.Value, After:=rFoundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
On Error Resume Next
If Not rFoundCell Is Nothing Then
myRegion = rFoundCell.CurrentRegion.Address(True, True)
myStart = Split(myRegion, ":")(0)
myEnd = Split(myRegion, ":")(1)
myEndCol = Split(myEnd, "$")(1)
myStartRow = Split(myStart, "$")(2) + 1
myEndRow = Split(myEnd, "$")(2) - 1
If myEndRow = "" Then GoTo SkipMe
With Sheets("YTD")
lrYTD = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
ws.Range(ws.Cells(myStartRow, "A"), ws.Cells(myEndRow, myEndCol)).Copy
.Range("A" & lrYTD).PasteSpecial
Application.CutCopyMode = False
End With
End If
On Error GoTo 0
SkipMe:
ws.Range("A2").EntireRow.Delete
End If
myRegion = ""
myStart = ""
myEnd = ""
myStartRow = ""
myEndRow = ""
Next ws
With Sheets("YTD")
lrYTD = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
.Range("M" & lrYTD).Formula = "=L" & lrYTD & "/" & "J" & lrYTD & ""
.Range("M" & lrYTD).Interior.Color = 65535
With .Range("M" & lrYTD).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 8
End With
.Range("H" & lrYTD).Value = cel.Value & " Totals"
.Range("H" & lrYTD).Interior.Color = 65535
With .Range("H" & lrYTD).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 8
End With
End With
Next cel
Call Totals
Application.ScreenUpdating = True
End Sub
Sub Totals()
Dim ws As Worksheet
Dim rng As Range
Dim r As Range
Dim ColNo As Long
Set ws = Sheets("YTD")
On Error Resume Next
With ws
For ColNo = 9 To 12
Set rng = .Columns(ColNo).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rng Is Nothing Then
For Each r In rng.Areas 'loop through each area within range
'all areas may vary in length/no. of rows, why r(r.cound)(2,1) is used
' the (2,1) is the same as .Offset(1) and you could prob use r(r.count+1).formula instead...
r(r.Count)(2, 1).Formula = "=SUM(" & r.Address & ")"
r(r.Count)(2, 1).NumberFormat = "$#,##0.00"
r(r.Count)(2, 1).Font.Name = "Arial"
r(r.Count)(2, 1).Font.FontStyle = "Bold"
r(r.Count)(2, 1).Font.Size = 8
r(r.Count)(2, 1).Interior.Color = 65535
On Error Resume Next
Next
End If
Next ColNo
On Error Resume Next
For ColNo = 16 To 19
Set rng = .Columns(ColNo).SpecialCells(xlCellTypeConstants) 'all constants in Col. J
On Error GoTo 0
If Not rng Is Nothing Then
For Each r In rng.Areas 'loop through each area within range
'all areas may vary in length/no. of rows, why r(r.cound)(2,1) is used
' the (2,1) is the same as .Offset(1) and you could prob use r(r.count+1).formula instead...
r(r.Count)(2, 1).Formula = "=SUM(" & r.Address & ")"
r(r.Count)(2, 1).NumberFormat = "$#,##0.00"
r(r.Count)(2, 1).Font.Name = "Arial"
r(r.Count)(2, 1).Font.FontStyle = "Bold"
r(r.Count)(2, 1).Font.Size = 8
r(r.Count)(2, 1).Interior.Color = 65535
Next
End If
Next ColNo
.Range("A2:A2").EntireRow.Delete
.Activate
End With
End Sub
Display More
