|
Option Explicit
Sub summary()
Dim rng As Range, rngC As Range
Dim lngCol As Long
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet
Set rng = .ListObjects(1).Range
If rng Is Nothing Then Exit Sub
.Copy after:=ActiveSheet
End With
With ActiveSheet
.Name = rng.Parent.Name & " Summary"
If .AutoFilterMode Then .ShowAllData
.Range(.Cells(1, 7), .Cells(1, 8)) = "XXX"
.Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).Formula = "=IF(OR(F2="""",COUNTIF($F$2:F2,F2)=1),""x"","""")"
.Range(.Cells(2, 8), .Cells(rng.Rows.Count - 1, 8)).Formula = "=SUMIF(F:F,F2,E:E)"
Set rngC = .Columns(7).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
Set rngC = .Columns(8).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
For Each rngC In .Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).SpecialCells(xlCellTypeConstants)
rngC.Offset(0, -2) = rngC.Offset(0, 1).Value
Next
.Cells(1, 7).CurrentRegion.Sort .Cells(1, 7), xlAscending, Header:=xlYes
Set rngC = .Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).SpecialCells(xlCellTypeBlanks)
If Not rngC Is Nothing Then rngC.EntireRow.Delete
.Columns(8).Delete
.Columns(7).Delete
End With
Application.ScreenUpdating = True
Set rng = Nothing
Set rngC = Nothing
End Sub
|