I think you'd have to be nuts to lose your nicely formatted data. But by
keeping it in a tabular format, you can do lots of nice things--including the
nutty stuff!
This seemed to work ok for me:
Option Explicit
Sub testme()
Application.ScreenUpdating = False
Dim curwks As Worksheet
Dim tempWks As Worksheet
Dim newWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim oRow As Long
Set curwks = Worksheets("sheet1")
Set tempWks = Worksheets.Add
With curwks
Set myRng = .Range("a1:d" & .Cells(.Rows.Count, "A").End(xlUp).Row)
myRng.Sort key1:=.Range("a1"), order1:=xlAscending, header:=xlYes
myRng.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=tempWks.Range("A1"), Unique:=True
End With
'get the subtotals
With tempWks
.Range("b2:b" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula _
= "=sumif(" & myRng.Columns(1).Address(external:=True) & ",a2," & _
myRng.Columns(4).Address(external:=True) & ")"
End With
Set newWks = Worksheets.Add
newWks.Range("a1:c1").Value = Array("INDUSTRY", "SECURITY", "QTY")
oRow = 0
With newWks
For Each myCell In myRng.Resize(myRng.Rows.Count - 1, 1) _
.Offset(1, 0).Cells
If myCell.Value <> myCell.Offset(-1, 0).Value Then
oRow = oRow + 2
.Cells(oRow, 1).Value = myCell.Value & " / " _
& Application.VLookup(myCell.Value, _
tempWks.Range("a:b"), 2, False)
End If
oRow = oRow + 1
.Cells(oRow, 2).Value = myCell.Offset(0, 1).Value
oRow = oRow + 1
.Cells(oRow, 2).Value = myCell.Offset(0, 2).Value
.Cells(oRow, 3).Value = myCell.Offset(0, 3).Value
Next myCell
.UsedRange.Columns.AutoFit
End With
With Application
.DisplayAlerts = False
tempWks.Delete
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
