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
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