PDA

View Full Version : Optomize Code for a Sort and Remove Duplicates Macro



Loss1003
03-07-2016, 08:31 AM
Optimize Code for a Sort and then Remove Duplicates Macro

I use the following code to Copy, Sort and then Remove Duplicates and paste them onto another worksheet. Also, uploads to a few combo-boxes located in my userform. The code works great, except now that I have over 7,000 rows the code is a bit slow. Therefore, every time I want to refresh the form its slow to re-open.

I was hoping for some suggestions on how to run the code more efficiently and faster. Thanks


Option Explicit

Sub SortAndRemoveDupes()
Dim rListSort1 As Range, rOldList1 As Range
Dim rListSort2 As Range, rOldList2 As Range
Dim rListSort3 As Range, rOldList3 As Range
Dim rListSort4 As Range, rOldList4 As Range
Dim rListSort5 As Range, rOldList5 As Range
Dim rListSort6 As Range, rOldList6 As Range

Dim StrRowSource1 As String
Dim StrRowSource2 As String
Dim StrRowSource3 As String
Dim StrRowSource4 As String
Dim StrRowSource5 As String
Dim StrRowSource6 As String

'Clear Hidden sheet Column A ready for list
Sheet3.Range("A1", Sheet3.Range("A65536").End(xlUp)).Clear
Sheet3.Range("B1", Sheet3.Range("B65536").End(xlUp)).Clear
Sheet3.Range("C1", Sheet3.Range("C65536").End(xlUp)).Clear
Sheet3.Range("D1", Sheet3.Range("D65536").End(xlUp)).Clear
Sheet3.Range("E1", Sheet3.Range("E65536").End(xlUp)).Clear
Sheet3.Range("F1", Sheet3.Range("F65536").End(xlUp)).Clear


'Set range variable to list we want
Set rOldList1 = Sheet2.Range("A1", Sheet2.Range("A65536").End(xlUp))
Set rOldList2 = Sheet2.Range("D1", Sheet2.Range("D65536").End(xlUp))
Set rOldList3 = Sheet2.Range("H1", Sheet2.Range("H65536").End(xlUp))
Set rOldList4 = Sheet2.Range("Q1", Sheet2.Range("Q65536").End(xlUp))
Set rOldList5 = Sheet2.Range("R1", Sheet2.Range("R65536").End(xlUp))
Set rOldList6 = Sheet2.Range("S1", Sheet2.Range("S65536").End(xlUp))



'Use AdvancedFilter to copy the list to Column A _
of the hidden sheet and remove all dupes
rOldList1.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 1), Unique:=True
rOldList2.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 2), Unique:=True
rOldList3.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 3), Unique:=True
rOldList4.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 4), Unique:=True
rOldList5.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 5), Unique:=True
rOldList6.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheet3.Cells(1, 6), Unique:=True

'Set range variable to the new non dupe list
Set rListSort1 = Sheet3.Range("A1", Sheet3.Range("A65536").End(xlUp))
Set rListSort2 = Sheet3.Range("B1", Sheet3.Range("B65536").End(xlUp))
Set rListSort3 = Sheet3.Range("C1", Sheet3.Range("C65536").End(xlUp))
Set rListSort4 = Sheet3.Range("D1", Sheet3.Range("D65536").End(xlUp))
Set rListSort5 = Sheet3.Range("E1", Sheet3.Range("E65536").End(xlUp))
Set rListSort6 = Sheet3.Range("F1", Sheet3.Range("F65536").End(xlUp))

With rListSort1
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With rListSort2
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With rListSort3
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With rListSort4
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
With rListSort5
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
With rListSort6
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With


'Parse the address of the sorted unique items
StrRowSource1 = Sheet3.Name & "!" & Sheet3.Range _
("A2", Sheet3.Range("A65536").End(xlUp)).Address
StrRowSource2 = Sheet3.Name & "!" & Sheet3.Range _
("B2", Sheet3.Range("B65536").End(xlUp)).Address
StrRowSource3 = Sheet3.Name & "!" & Sheet3.Range _
("C2", Sheet3.Range("C65536").End(xlUp)).Address
StrRowSource4 = Sheet3.Name & "!" & Sheet3.Range _
("D2", Sheet3.Range("D65536").End(xlUp)).Address
StrRowSource5 = Sheet3.Name & "!" & Sheet3.Range _
("E2", Sheet3.Range("E65536").End(xlUp)).Address
StrRowSource6 = Sheet3.Name & "!" & Sheet3.Range _
("F2", Sheet3.Range("F65536").End(xlUp)).Address

Sheet3.Range("A1") = "New Sorted Unique List"
Sheet3.Range("B1") = "New Sorted Unique List"
Sheet3.Range("C1") = "New Sorted Unique List"
Sheet3.Range("D1") = "New Sorted Unique List"
Sheet3.Range("E1") = "New Sorted Unique List"
Sheet3.Range("F1") = "New Sorted Unique List"


With UserForm1.Acname1
.RowSource = vbNullString
.RowSource = StrRowSource1
End With

With UserForm1.Year1
.RowSource = vbNullString
.RowSource = StrRowSource2
End With

With UserForm1.Dept1
.RowSource = vbNullString
.RowSource = StrRowSource3
End With

With UserForm1.Req1
.RowSource = vbNullString
.RowSource = StrRowSource4
End With

With UserForm1.Req2
.RowSource = vbNullString
.RowSource = StrRowSource5
End With

With UserForm1.Req3
.RowSource = vbNullString
.RowSource = StrRowSource6
End With



End Sub

Paul_Hossler
03-07-2016, 11:26 AM
1. It might be easier to use arrays instead of repeating code six times

2. There is a [Remove Duplicates] method that I've always found to be very fast. You'd have to integrate it into your code




Option Explicit

Sub SortAndRemoveDupes()
Dim aListSort(1 To 6) As Range
Dim aOldList(1 To 6) As Range
Dim aStrRowSource(1 To 6) As String
Dim iCol As Long

'Clear Hidden sheet Column A ready for list
With Sheet3
For iCol = 1 To 6
Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp)).Clear
Next iCol
End With



'Set range variable to list we want
With Sheet2
For iCol = 1 To 6
Set aOldList(iCol) = Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
Next iCol
End With


'Use AdvancedFilter to copy the list to Column A of the hidden sheet And remove all dupes
For iCol = 1 To 6
aOldList(iCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet3.Cells(1, iCol), Unique:=True
Next iCol

'Set range variable to the new non dupe list
With Sheet3
For iCol = 1 To 6
Set aListSort(iCol) = Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp))
Next iCol
End With

For iCol = 1 To 6
With aListSort(iCol)
'Sort the new non dupe list
.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Next iCol

With Sheet3
For iCol = 1 To 6
.Cells(1, iCol) = "New Sorted Unique List"
'Parse the address of the sorted unique items
aStrRowSource(iCol) = .Name & "!" & Range(.Cells(2, iCol), .Cells(.Rows.Count, iCol).End(xlUp)).Address
Next iCol
End With


With UserForm1.Acname1
.RowSource = vbNullString
.RowSource = aStrRowSource(1)
End With

With UserForm1.Year1
.RowSource = vbNullString
.RowSource = aStrRowSource(2)
End With

With UserForm1.Dept1
.RowSource = vbNullString
.RowSource = aStrRowSource(3)
End With

With UserForm1.Req1
.RowSource = vbNullString
.RowSource = aStrRowSource(4)
End With

With UserForm1.Req2
.RowSource = vbNullString
.RowSource = aStrRowSource(5)
End With

With UserForm1.Req3
.RowSource = vbNullString
.RowSource = aStrRowSource(6)
End With



End Sub









Sub Macro1()
ActiveSheet.Range("$A$1:$A$39").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub