Code works just slow

[henrybrent1974]

Just wondering if there might be a better way for this to be written. I copied bits of code and did a record macro and put it all together to make it work for what i want but it takes a while for it to run. Any help would be appreciated.

Sub AllPlayersList()
    Dim folderPath As String
    Dim fileName As String
    Dim thisWorkbook As Workbook
    Dim dayNumber As Integer
    Dim workbookDate As Date
    Dim rowOffset As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    folderPath = "C:\Users\Brent.WSN\Documents\Dukes Tournament of Champions\Weekly\"
    
    Set thisWorkbook = ActiveWorkbook
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    rowOffset = 0
    fileName = Dir(folderPath & "*.xlsm")
    Do While fileName <> ""
        
        Workbooks.Open folderPath & fileName
        
        Sheets("Sign Up").Range("C4:C35").Copy thisWorkbook.Sheets("Summary").Range("AE" & Rows.Count).End(xlUp)(2)
        ActiveWorkbook.Close SaveChanges:=False
        
        fileName = Dir
    Loop
    
    Dim ws As Worksheet
    Dim lastRow As Long, x As Long
    Dim items As Object
    
    Set ws = Sheet1
    
    lastRow = ws.Range("AE" & Rows.Count).End(xlUp).Row
    
    Set items = CreateObject("Scripting.Dictionary")
    For x = 1 To lastRow
        If Not items.exists(ws.Range("AE" & x).Value) Then
            items.Add ws.Range("AE" & x).Value, 1
            ws.Range("AF" & x).Value = items(ws.Range("AE" & x).Value)
        Else
            items(ws.Range("AE" & x).Value) = items(ws.Range("AE" & x).Value) + 1
            ws.Range("AF" & x).Value = items(ws.Range("AE" & x).Value)
        End If
    Next x
    On Error Resume Next
    
 If Not Intersect(Target, Range("AF2:AF1024")) Is Nothing Then
 Range("AF1").Sort Key1:=Range("AF2"), _
 Order1:=xlDescending, Header:=xlYes, _
 OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom
 End If

    ActiveSheet.Range("$AE$1:$AF$1024").RemoveDuplicates Columns:=1, Header:=xlYes
        
    Range("AE2:AF2").Select
    Selection.Delete Shift:=xlUp
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

 

[igold]

Just wondering if there might be a better way for this to be written. I copied bits of code and did a record macro and put it all together to make it work for what i want but it takes a while for it to run. Any help would be appreciated.

Sub AllPlayersList()
    Dim folderPath As String
    Dim fileName As String
    Dim thisWorkbook As Workbook
    Dim dayNumber As Integer
    Dim workbookDate As Date
    Dim rowOffset As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    folderPath = "C:\Users\Brent.WSN\Documents\Dukes Tournament of Champions\Weekly\"
    
    Set thisWorkbook = ActiveWorkbook
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    rowOffset = 0
    fileName = Dir(folderPath & "*.xlsm")
    Do While fileName <> ""
        
        Workbooks.Open folderPath & fileName
        
        Sheets("Sign Up").Range("C4:C35").Copy thisWorkbook.Sheets("Summary").Range("AE" & Rows.Count).End(xlUp)(2)
        ActiveWorkbook.Close SaveChanges:=False
        
        fileName = Dir
    Loop
    
    Dim ws As Worksheet
    Dim lastRow As Long, x As Long
    Dim items As Object
    
    Set ws = Sheet1
    
    lastRow = ws.Range("AE" & Rows.Count).End(xlUp).Row
    
    Set items = CreateObject("Scripting.Dictionary")
    For x = 1 To lastRow
        If Not items.exists(ws.Range("AE" & x).Value) Then
            items.Add ws.Range("AE" & x).Value, 1
            ws.Range("AF" & x).Value = items(ws.Range("AE" & x).Value)
        Else
            items(ws.Range("AE" & x).Value) = items(ws.Range("AE" & x).Value) + 1
            ws.Range("AF" & x).Value = items(ws.Range("AE" & x).Value)
        End If
    Next x
    On Error Resume Next
    
 If Not Intersect(Target, Range("AF2:AF1024")) Is Nothing Then
 Range("AF1").Sort Key1:=Range("AF2"), _
 Order1:=xlDescending, Header:=xlYes, _
 OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom
 End If

    ActiveSheet.Range("$AE$1:$AF$1024").RemoveDuplicates Columns:=1, Header:=xlYes
        
    Range("AE2:AF2").Select
    Selection.Delete Shift:=xlUp
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

With the below change to the Red highlighted portion of your code above, I was able to cut the amount of time the code spent in this For/Next by more than 50%

    Dim ws As Worksheet
    Dim lastRow As Long, x As Long
    Dim items As Object
    Dim nr
    
    
    Set ws = Sheet1
    
    lastRow = ws.Range("AE" & Rows.Count).End(xlUp).Row
    xx = 1
    ReDim nr(1 To lastRow, 1 To 1)
    Set items = CreateObject("Scripting.Dictionary")
    For x = 1 To lastRow
        If Not items.exists(ws.Range("AE" & x).Value) Then
            items.Add ws.Range("AE" & x).Value, 1
            nr(x, 1) = items(ws.Range("AE" & x).Value)
        Else
            items(ws.Range("AE" & x).Value) = items(ws.Range("AE" & x).Value) + 1
            nr(x, 1) = items(ws.Range("AE" & x).Value)
        End If
    Next x
    Range("AF1").Resize(UBound(nr)) = nr