First off, an excellent, thoroughly detailed and coherent question. Often the greatest challenge of all is to get a complex scenario across in the first instance - I feel you achieved that here...
The below will I *think* get you close to what you want but it's highly unlikely to do everything given this was a dummy file and the real version is likely to be far more complex... anyway I hope it helps to some extent.
Public Sub Demo()
Dim wsData As Worksheet, wsTitle As Worksheet, wsOwners As Worksheet
Dim xlCalc As XlCalculation
Dim rngData As Range, rngOwners As Range, rngOwner As Range, rngTitles As Range, rngTitle As Range
Dim rngX As Range, rngResult As Range, rngVisible As Range, rngCell As Range
Dim strRows As String
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set wsData = Sheets("Data")
Set wsTitle = Sheets("Assignment")
Set wsOwners = Sheets("Email Addr")
Set rngData = Range("dataset")
Range("Status_Col").Resize(1 + rngData.Rows.Count, rngData.Columns.Count).AutoFilter field:=1, Criteria1:="Include"
With wsTitle: Set rngTitles = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)): End With
With wsOwners: Set rngOwners = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)): End With
For Each rngOwner In rngOwners.Cells
strRows = ""
If rngOwner.Value <> "" Then
With wsTitle: rngTitles.Offset(-1).Resize(1 + rngTitles.Rows.Count, 3).AutoFilter field:=3, Criteria1:=rngOwner.Value: End With
For Each rngTitle In rngTitles.SpecialCells(xlCellTypeVisible)
If rngTitle.Value <> "" Then
Set rngX = Range(rngTitle.Offset(, 1).Value).Offset(1).Resize(rngData.Rows.Count)
With wsData
With rngX.SpecialCells(xlCellTypeVisible).Offset(, .Columns.Count - rngX.Column)
.FormulaR1C1 = "=IF(RC" & rngX.Column & "<>R" & rngX.Offset(-2).Row & "C" & rngX.Column & ",ADDRESS(ROW()," & rngX.Column & "),0)"
On Error Resume Next
For Each rngResult In .Cells.SpecialCells(xlCellTypeFormulas, xlTextValues)
strRows = strRows & "," & rngResult.Value
Next rngResult
On Error GoTo 0
.Clear
End With
End With
Set rngX = Nothing
End If
Next rngTitle
With wsTitle: rngTitles.Rows(1).AutoFilter: End With
End If
If strRows <> "" Then
Set rngVisible = wsData.Range(Replace(strRows, ",", "", 1, 1))
rngData.Rows.Hidden = True: rngData.Columns.Hidden = True
For Each rngCell In rngVisible.Cells
rngCell.EntireColumn.Hidden = False: rngCell.EntireRow.Hidden = False
Next rngCell
'copy results to new file
wsData.UsedRange.Cells.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
With ActiveSheet.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'issue new file to owner
With ActiveWorkbook
.SendMail Recipients:=rngOwner.Offset(, 1).Value
.Close False
End With
Set rngVisible = Nothing
rngData.Columns.Hidden = False
Range("Status_Col").Resize(1 + rngData.Rows.Count, rngData.Columns.Count).AutoFilter field:=1, Criteria1:="Include"
End If
Next rngOwner
rngData.Offset(-1).Resize(1).AutoFilter
ExitPoint:
Set wsOwners = Nothing
Set wsTitle = Nothing
Set wsData = Nothing
With Application
.Calculation = xlCalc
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
Handler:
MsgBox "Error Has Occurred" & vbLf & vbLf & _
"Error Number: " & Err.Number & vbLf & vbLf & _
"Error Desc.: " & Err.Description, _
vbCritical, _
"Fatal Error"
Resume ExitPoint
End Sub
Bookmarks