I am working on a code that has a series of metrics listed in rows.
Each metric is uniquely specified by several headings listed in the
header row. The (relevant) categories in the header are as follows:
|ID|Category|Sub-Category|Metric|Sub-Metric|Unit|Priority|etc...
(irrelevant)|
The entire worksheet needs to be sorted.
Because the heading labeled "Metric" can have multiple row entries of
the same value (string), I want to write a macro in which the rows
with all the same entries under the metric header are grouped
together, and sorted until each of the categories individually are
sorted. Then, I want the entire sheet to be sorted. However, by doing
this, I do not want the groups with the same "Metric" category labels
to become unsorted. I want them to be "glued" together, and sorted as
if the group were one row. The highest Priority of the group will
determine where it is placed on the worksheet (Priority is determined
by the labels 1,2,3,and ?. It is sorted in descending order - question
mark last)
Here is some code I have been working on:
Dim ws As Worksheet
Dim rowCount, subRowCount, idCount, letterCount, totCount, marker As
Integer
Dim letString, idLabel, curCell As String
Dim rowSelect As Long
'Predefine necessary variables
rowCount = 2 'Start at first row, excluding header
idCount = 1
letterCount = 0
'Determine Name of label
If ActiveSheet.Name = "Project Description" Then
idLabel = "ID-"
ElseIf ActiveSheet.Name = "Real Estate-Financial" Then
idLabel = "RF-"
ElseIf ActiveSheet.Name = "Building Features" Then
idLabel = "BF-"
ElseIf ActiveSheet.Name = "Green Features" Then
idLabel = "GF-"
ElseIf ActiveSheet.Name = "Operational" Then
idLabel = "OP-"
ElseIf ActiveSheet.Name = "Occupants" Then
idLabel = "OC-"
Else
idLabel = Application.InputBox("Please specify ID Label.", "ID
LABEL") + "-"
End If
'Find the last row with data in the sheet. Number of last row =
totCount
totCount = ActiveSheet.Range("A9999").End(xlUp).Row
'Loop through each cell in column D to determine if consecutive
metrics have the same value
'If true, while loop sorts each series of consecutive metrics
individually
'LATER, CONVER THIS INTO FIND ALL!!!!
Do
curCell = ActiveSheet.Cells(rowCount, 4) 'Selects cell in
'metric' column at row rowCount
subRowCount = rowCount + 1
'Makes a cell selection while cell values in column 4 are equal
If curCell = ActiveSheet.Cells(subRowCount, 4) Then '<<<NECESSARY?
ActiveSheet.Cells(rowCount, "L") = marker
Do
'Resize selection to include cell with same metric name
Selction.Resize(1).Select
'increment compare next two subesquent cells in sequence
rowCount = rowCount + 1
subRowCount = rowCount + 1
curCell = ActiveSheet.Cells(rowCount, 4)
'Establish place holder in col "L" (empty) to track groups
ActiveSheet.Cells(rowCount, "L") = marker
Loop While curCell = ActiveSheet.Cells(subRowCount, 4)
'to prevent subsequent groups of metrics from being sorted
together
marker = marker + 1
'Sort the existing selection. Should this be
selection.col("")?
Selection.EntireRow.Sort Key1:=col("G"), Order1:=xlDescending,
Key2:=col("B"), _
Order2:=xlDescending, key3:=col("C"), Order3:=xlDescending,
key4:=col("D"), _
order4:=xlDescending, key5:=col("E"), Order5:=xlDescending
'^^^In the future we will want the preceeding code to find all
similar cells
Else
rowCount = rowCount + 1
End If
Loop Until rowCount = totCount
'Sort through remaining worksheet while keep cell groups intact
'Should treat cells a
ActiveSheet.EntireRow.Sort Key1:=col("G"), Order1:=xlDescending,
Key2:=col("B"), _
Order2:=xlDescending, key3:=col("C"), Order3:=xlDescending,
key4:=col("D"), _
order4:=xlDescending, key5:=col("E"), Order5:=xlDescending
'resets rowCount to start at the first row (excluding header)
rowCount = 2
'Loops through each cell, looks at column L, if marker is present,
'id labels loop through letterCount to find appropriate ID label
Do
If ActiveSheet.Cells(rowCount, "L") = ActiveSheet.Cells(rowCount +
1, "L") Then
'Labels sub-metirc "idLabel-rowCount"A,B,C,etc."" for as long
as marker is present in column L
Do
ActiveSheet.Cells(rowCount, "A") = idLabel &
rowCount.String & letString(letterCount) 'trying to index string
letterCount = letterCount + 1
rowCount = rowCount + 1
Loop While ActiveSheet.Cells(rowCount, "L") <> Empty _
And ActiveSheet.Cells(rowCount, "L") =
ActiveSheet.Cells(rowCount + 1, "L")
Else:
ActiveSheet.Cells(rowCount, "A") = idLabel & rowCount.String
End If
letterCount = 1
rowCount = rowCount + 1
Loop While rowCount <> totCount
'EVENTUALLY WE WILL WANT TO COMBINE TWO LOOPS SO PROGRAM RUNS MORE
EFFICIENTLY
A reference to the file can be found here From the file you can see
that the cells are sorted by priority, yet the previously sorted
groups will be sorted as a single row within the worksheet. Again, the
cell within the group which has the highest priority will cause the
group to be sorted according to that priority.
There exists another caveat. Some of these groups will have hidden
cells, which are referenced by a list validation adjacent to the
hidden cells. If possible, I want to be able to sort the list, while
keeping the hidden cells intact. As in, the clusters of hidden cells
will be grouped together with row where the list is located and sorted
within the whole list but not within the cluster itself (Just like the
groups previously mentioned).
I also want to maintain the presence of the list, as I have noticed
the lists completely disappear when I use the sort command in excel.
Can anyone help me with the first and/or second part of the questions?
This seems rather tough so I appreciate your help greatly.
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
<><><><><><><><><><><><><><><><><><><><><><>
Like our page on facebook , Just follow below link
http://www.facebook.com/discussexcel
