A vb sorting problem

Here, I am writing code for Ladies_Fashion' only.
try similarly for other categories.

1)in sheet 2, at cell a3, type
=Sheet1!B15

2)in sheet 2, at cell b3, type  
=Sheet1!C15

3)in sheet 2, at cell c3, type  
=COUNT(Sheet1!E15)+COUNT(Sheet1!O15)+COUNT(Sheet1!Y15)+COUNT(Sheet1!AI15)+COUNT(Sheet1!AS15)+COUNT(Sheet1!BC15)+COUNT(Sheet1!BM15)+COUNT(Sheet1!BW15)+COUNT(Sheet1!CG15)+COUNT(Sheet1!CQ15)+COUNT(Sheet1!DA15)+COUNT(Sheet1!DK15)+COUNT(Sheet1!DU15)+COUNT(Sheet1!EE15)

4)in sheet 2, at cell d3, type  
=SUM(Sheet1!E15)+SUM(Sheet1!O15)+SUM(Sheet1!Y15)+SUM(Sheet1!AI15)+SUM(Sheet1!AS15)+SUM(Sheet1!BC15)+SUM(Sheet1!BM15)+SUM(Sheet1!BW15)+SUM(Sheet1!CG15)+SUM(Sheet1!CQ15)+SUM(Sheet1!DA15)+SUM(Sheet1!DK15)+SUM(Sheet1!DU15)+SUM(Sheet1!EE15)

5) copy the above four cell values to remaining rows.

6) for sorting use in a macro editor the following code,

Range("A3:D10000").Select
ActiveWorkbook.Names.Add Name:="Ladies_Fashion", RefersToR1C1:="=Sheet2!R3C1:R10000C4"
Selection.Copy
Selection.Sort Key1:=Range("D3"), Order1:=xlDescending, Header:=xlGuess, _
  OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   
hope this helps,
from
SriRamIyer.

Hi D4,

You didn't mention it but I assumed that you would want to move the names over to Sheet2 also.  This looks like it does what you wanted:

(Add this to Module1)

Sub SumSortTests()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, cel As Range, ce As Range
Dim i As Long, j As Long, m As Long, n As Long

Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")

Set rng = ws1.Range(ws1.Range("E15"), ws1.Cells(ws1.Cells(ws1.Cells.Rows.Count, 1).End(xlUp).Row, 144))

m = 3
For Each ce In Intersect(rng.Columns(1), rng)
    For i = 1 To rng.Columns.Count Step 10
        For j = 1 To 10
            Set cel = rng.Cells(ce.Row - rng.Row + 1, (i - 1) + j)
            If IsNumeric(cel) And cel <> "" Then
                n = (j - 1) * 4 + 1
                If Trim(ws2.Cells(m, n) & ws2.Cells(m, n + 1)) = "" Then
                    ws2.Cells(m, n) = ce.Offset(0, -3)
                    ws2.Cells(m, n + 1) = ce.Offset(0, -2)
                End If
                ws2.Cells(m, n + 2) = ws2.Cells(m, n + 2) + 1
                ws2.Cells(m, n + 3) = ws2.Cells(m, n + 3) + cel.Value
            End If
        Next j
    Next i
    m = m + 1
Next ce

For i = 1 To 10
    Set rng = Intersect(ws2.Range(ws2.Columns((i - 1) * 4 + 1), ws2.Columns((i - 1) * 4 + 4)), ws2.UsedRange).Offset(1)
    rng.Sort Key1:=rng.Cells(4), Order1:=xlDescending, _
                Key2:=rng.Cells(3), Order2:=xlDescending, Header:=xlYes
Next i

Application.ScreenUpdating = True

End Sub

Jim