Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations biv343 on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Spaghetti Anyone?

Status
Not open for further replies.
Finality

Finality

MIS
Jun 9, 2003
4
US
I need help cleaning up the following code. I have multiple columns of metrics that each have to be sorted individually and then pasted below creating a total of 3 sections. First, I would like to clean up the existing code. Second, I need to change the sort to account for "ties in the data". Instead of a ranking like

1
2
3
4
5
6
7

A tie would be recognized as

1
2
3
3
4
5
6


Any assistance from the gurus here would be incredible.

Italian follows:

Sub SortnRank()


Dim r1 As Range, r1a As Range, r2 As Range, r2a As Range, r3 As Range, _
r3a As Range, r4 As Range, r4a As Range, r5 As Range, r5a As Range, _
r7 As Range, r7a As Range, r8 As Range, r8a As Range, r9 As Range, r9a As Range, _
r10 As Range, r10a As Range, r11 As Range, r11a As Range, r12 As Range, r12a As Range, _
r13 As Range, r13a As Range, r14 As Range, r14a As Range, r15 As Range, r15a As Range, _
r16 As Range, r16a As Range, r17 As Range, r17a As Range, r18 As Range, r18a As Range, _
r19 As Range, r19a As Range, r20 As Range, r20a As Range

Worksheets("Data").Activate
ActiveSheet.Unprotect
Cells.Select
Selection.EntireRow.Hidden = False


Set r1 = Range("a5:b44")
Set r1a = Range("a5:c44")
Set r2 = Range("d5:e44")
Set r2a = Range("d5:f44")
Set r3 = Range("g5:h44")
Set r3a = Range("g5:i44")
Set r4 = Range("j5:k44")
Set r4a = Range("j5:l44")
Set r5 = Range("m5:n44")
Set r5a = Range("m5:eek:44")
Set r7 = Range("p5:q44")
Set r7a = Range("p5:r44")
Set r8 = Range("s5:t44")
Set r8a = Range("s5:u44")
Set r9 = Range("v5:w44")
Set r9a = Range("v5:x44")
Set r10 = Range("y5:z44")
Set r10a = Range("y5:aa44")
Set r11 = Range("ab5:ac44")
Set r11a = Range("ab5:ad44")
Set r12 = Range("ae5:af44")
Set r12a = Range("ae5:ag44")
Set r13 = Range("ah5:ai44")
Set r13a = Range("ah5:aj44")
Set r14 = Range("ak5:al44")
Set r14a = Range("ak5:am44")
Set r15 = Range("an5:ao44")
Set r15a = Range("an5:ap44")
Set r16 = Range("aq5:ar44")
Set r16a = Range("aq5:as44")
Set r17 = Range("at5:au44")
Set r17a = Range("at5:av44")
Set r18 = Range("aw5:ax44")
Set r18a = Range("aw5:ay44")
Set r19 = Range("az5:ba44")
Set r19a = Range("az5:bb44")
Set r20 = Range("bc5:bd44")
Set r20a = Range("bc5:be44")


Application.ScreenUpdating = False 'Hides all the screen changes until macro is complete

' Sorts all categories first by metric, then by Sales Consultant

r1.Select
Selection.Sort Key1:=Range("b5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r1a.Copy Range("a46")
r1a.Select
Selection.Sort Key1:=Range("a5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r1a.Copy Range("a87")

r2.Select
Selection.Sort Key1:=Range("e5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r2a.Copy Range("d46")
r2a.Select
Selection.Sort Key1:=Range("d5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r2a.Copy Range("d87")

r3.Select
Selection.Sort Key1:=Range("h5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r3a.Copy Range("g46")
r3a.Select
Selection.Sort Key1:=Range("g5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r3a.Copy Range("g87")

r4.Select
Selection.Sort Key1:=Range("k5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r4a.Copy Range("j46")
r4a.Select
Selection.Sort Key1:=Range("j5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r4a.Copy Range("j87")

r5.Select
Selection.Sort Key1:=Range("n5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r5a.Copy Range("m46")
r5a.Select
Selection.Sort Key1:=Range("m5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r5a.Copy Range("m87")

r7.Select
Selection.Sort Key1:=Range("q5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r7a.Copy Range("p46")
r7a.Select
Selection.Sort Key1:=Range("p5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r7a.Copy Range("p87")

r8.Select
Selection.Sort Key1:=Range("t5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r8a.Copy Range("s46")
r8a.Select
Selection.Sort Key1:=Range("s5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r8a.Copy Range("s87")

r9.Select
Selection.Sort Key1:=Range("w5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r9a.Copy Range("v46")
r9a.Select
Selection.Sort Key1:=Range("v5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r9a.Copy Range("v87")

r10.Select
Selection.Sort Key1:=Range("z5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r10a.Copy Range("y46")
r10a.Select
Selection.Sort Key1:=Range("y5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r10a.Copy Range("y87")

r11.Select
Selection.Sort Key1:=Range("ac5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r11a.Copy Range("ab46")
r11a.Select
Selection.Sort Key1:=Range("ab5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r11a.Copy Range("ab87")

r12.Select
Selection.Sort Key1:=Range("af5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r12a.Copy Range("ae46")
r12a.Select
Selection.Sort Key1:=Range("ae5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r12a.Copy Range("ae87")

r13.Select
Selection.Sort Key1:=Range("ai5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r13a.Copy Range("ah46")
r13a.Select
Selection.Sort Key1:=Range("ah5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r13a.Copy Range("ah87")

r14.Select
Selection.Sort Key1:=Range("al5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r14a.Copy Range("ak46")
r14a.Select
Selection.Sort Key1:=Range("ak5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r14a.Copy Range("ak87")

r15.Select
Selection.Sort Key1:=Range("ao5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r15a.Copy Range("an46")
r15a.Select
Selection.Sort Key1:=Range("an5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r15a.Copy Range("an87")

r16.Select
Selection.Sort Key1:=Range("ar5"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r16a.Copy Range("aq46")
r16a.Select
Selection.Sort Key1:=Range("aq5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r16a.Copy Range("aq87")

r17.Select
Selection.Sort Key1:=Range("au5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r17a.Copy Range("at46")
r17a.Select
Selection.Sort Key1:=Range("at5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r17a.Copy Range("at87")

r18.Select
Selection.Sort Key1:=Range("ax5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r18a.Copy Range("aw46")
r18a.Select
Selection.Sort Key1:=Range("aw5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r18a.Copy Range("aw87")

r19.Select
Selection.Sort Key1:=Range("ba5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r19a.Copy Range("az46")
r19a.Select
Selection.Sort Key1:=Range("az5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r19a.Copy Range("az87")
r20.Select
Selection.Sort Key1:=Range("bd5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r20a.Copy Range("bc46")
r20a.Select
Selection.Sort Key1:=Range("bc5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
r20a.Copy Range("bc87")


'sort entire section by rank ascending

Range("Overall").Select
Selection.Copy
Range("Overall_Value").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("Data_Sort").Select
Range("Data_SortValue").Activate
Selection.Sort Key1:=Range("Data_SortValue"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("a1").Select

Sheets("Data").Select
Call HideData

Call HideSummaryPenetration
Call HideSummaryRevenue




End Sub

Sub Reset_Consultants()

Application.ScreenUpdating = False

'Clear concatenated names for reset
Sheets("Sales Consultant Master List").Select
If ActiveSheet.ProtectContents Then
ActiveSheet.Unprotect
Range("Concatlist").ClearContents
Else
Range("Concatlist").ClearContents
End If
'Recognize list of Sales Consultants and concatenate
Range("c3").Select

' Set Do loop to stop when an empty cell is reached.
Do While ActiveCell <> &quot;&quot; 'Loops until the active cell is blank.

'The &quot;&&quot; must have a space on both sides or it will be
'treated as a variable type of long integer.

ActiveCell.Offset(0, 1).FormulaR1C1 = _
ActiveCell.Offset(0, -1) & &quot;, &quot; & ActiveCell.Offset(0, 0)
ActiveCell.Offset(1, 0).Select
Loop


'Prepare Data sheet for reset
Sheets(&quot;Data&quot;).Select
If ActiveSheet.ProtectContents Then
ActiveSheet.Unprotect
Cells.Select
Selection.EntireRow.Hidden = False
Range(&quot;A46:A130&quot;).Select
Selection.EntireRow.Delete
Range(&quot;Data_Sort&quot;).ClearContents
Range(&quot;Overall_SalesC&quot;).ClearContents
Else
Cells.Select
Selection.EntireRow.Hidden = False
Range(&quot;A46:A130&quot;).Select
Selection.EntireRow.Delete
Range(&quot;Data_Sort&quot;).ClearContents
Range(&quot;Overall_SalesC&quot;).ClearContents
Range(&quot;Overall_Clear&quot;).ClearContents
End If

'Reset Rank numbers
Range(&quot;C5&quot;).Select
ActiveCell.FormulaR1C1 = &quot;1&quot;
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=40, Trend:=False
Range(&quot;C5:C44&quot;).Copy Range(&quot;F5:F44,I5:I44,L5:L44,O5:O44,R5:R44,U5:U44,X5:X44,aa5:aa44,ad5:ad44,ag5:ag44,aj5:aj44,am5:am44,ap5:ap44,as5:as44,av5:av44,ay5:ay44,bb5:bb44,be5:be44&quot;)
Application.CutCopyMode = False
Range(&quot;b5&quot;).Select


'Select the Consultants for transfer to Data Sheet
Sheets(&quot;Sales Consultant Master List&quot;).Select
Range(&quot;b3:c42&quot;).Select
Selection.Sort Key1:=Range(&quot;b3&quot;), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets(&quot;Sales Consultant Master List&quot;).Select
Range(&quot;d3&quot;).Select
If IsEmpty(ActiveCell) Then Exit Sub
'ignore error if activecell is in Row 1
On Error Resume Next
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
Range(TopCell, BottomCell).Select

ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True

'Transfer the Consultants
Selection.Copy

Range(&quot;b3&quot;).Select
Sheets(&quot;Data&quot;).Select
Range(&quot;A5,D5,G5,J5,M5,P5,S5,V5,Y5,AB5,AE5,AH5,AK5,AN5,AQ5,AT5,AW5,AZ5,BC5,BF5,BI5&quot;).Select
Range(&quot;BI5&quot;).Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Columns.AutoFit
Application.CutCopyMode = False

ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True

'Unhide all rows in the summary worksheet
Sheets(&quot;Summary_Events&quot;).Select
If ActiveSheet.ProtectContents Then
ActiveSheet.Unprotect
Cells.Select
Selection.EntireRow.Hidden = False
End If
ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True
Range(&quot;A1&quot;).Select

Sheets(&quot;Data&quot;).Select

'hide unused rows
Call HideData

End Sub

Sub HideData()

Application.ScreenUpdating = False

Sheets(&quot;Data&quot;).Select
ActiveSheet.Unprotect
Range(&quot;A5&quot;).Select

Dim c As Range
For Each c In Intersect(ActiveSheet.UsedRange, Columns(1))
If IsEmpty(c) And IsEmpty(c.Offset(1, 0)) Then
c.EntireRow.Hidden = True
End If
Next c
ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True

End Sub

Sub HideSummaryPenetration()

Application.ScreenUpdating = False

Sheets(&quot;Summary_Events&quot;).Select
ActiveSheet.Unprotect
Range(&quot;B5&quot;).Select

Set currentCell = Sheets(&quot;Summary_Events&quot;).Range(&quot;B5&quot;)
Do While Not IsEmpty(currentCell)
Set nextcell = currentCell.Offset(1, 0)
If nextcell.Value = 0 And nextcell.Offset(-1, 0) = 0 Then
currentCell.EntireRow.Hidden = True
End If
Set currentCell = nextcell
Loop
ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True

End Sub

Sub HideSummaryRevenue()

Application.ScreenUpdating = False

Sheets(&quot;Summary_Events&quot;).Select
ActiveSheet.Unprotect
Range(&quot;B53&quot;).Select

Set currentCell = Sheets(&quot;Summary_Events&quot;).Range(&quot;B53&quot;)
Do While Not IsEmpty(currentCell)
Set nextcell = currentCell.Offset(1, 0)
If nextcell.Value = 0 And nextcell.Offset(-1, 0) = 0 Then
currentCell.EntireRow.Hidden = True
End If
Set currentCell = nextcell
Loop
ActiveSheet.Protect _
DrawingObjects:=True, _
Contents:=True

Range(&quot;A5&quot;).Select


End Sub

 
Sort by date Sort by votes
I'm afraid it's a little to a la dent for me to give you a complete solution, but here is an idea to replace a chunk of it. You don't need all of those range definitions and you definitely don't need all of that redundant code.

Here is how you can do the first part (sorts and copies):
[blue]
Code: 
Sub test()
Dim i As Integer
  For i = 1 To 55 Step 3
    DoSortAndCopy i
  Next i
End Sub

Sub DoSortAndCopy(AColumn As Integer)
Const BASE_RANGE = &quot;A5:B44&quot;
Const ALT_RANGE = &quot;A5:C44&quot;
Const DEST_1 = &quot;A46&quot;
Const DEST_2 = &quot;A87&quot;
Dim rng As Range
Dim sSortKey As String

  Set rng = Range(BASE_RANGE).Offset(0, AColumn - 1)
  sSortKey = rng.Cells(1, 2).Address(0, 0)
  rng.Sort Key1:=Range(sSortKey), Order1:=xlAscending, Header:=xlNo, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

  Set rng = Range(ALT_RANGE).Offset(0, AColumn - 1)
  rng.Copy Range(DEST_1).Offset(0, AColumn - 1)
  
  sSortKey = rng.Cells(1, 1).Address(0, 0)
  rng.Sort Key1:=Range(sSortKey), Order1:=xlAscending, Header:=xlNo, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  rng.Copy Range(DEST_2).Offset(0, AColumn - 1)
  
  Set rng = Nothing
End Sub
[/color]
I don't know if I'll have the time (or the stomach) to work on the remainder later. But at least this is a start.

 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

calpolymis
  • Locked
  • Question
Can anyone help with this simle calculation? I can't verify my answer.
Replies
7
Views
122
mikrom
mikrom
tedb13
  • Locked
  • Question
Can anyone explain how text gets smaller and smaller each time you toggle through a texbox?
Replies
3
Views
69
combo
combo
LGMan
  • Locked
  • Question
Hi, can anyone help with a little t 2
Replies
9
Views
147
Gruuuu
Gruuuu
DougP
  • Locked
  • Question
Anyone know how to get to Adobe Acrobat objexts using VBA?
Replies
1
Views
111
MarkWalsh
MarkWalsh
pmmd861
  • Locked
  • Question
Does anyone know what this code is doing? 1
Replies
3
Views
46
pmmd861
pmmd861

Part and Inventory Search

Sponsor

Back
Top