Optomize Code for a Sort and Remove Duplicates Macro

[Loss1003]

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]

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