Excel Slow performance

[Paul_Hossler]

Thanks buddy.
You are write Vlookup is Simpler, but does it actually slows down things when compared to Index Match, if Vlookup is better option I don't mind using it.

There are no specific rules in WB and WB,
WB dates starts From Sunday
WE dates starts from Saturday

Well, I don't know if VLookup is slower than Match/Index, but I added the VBA equivalent (using arrays for the Mapping tables) A collection or dictionary seems like over-kill

I compute the WB/WE dates -- note that you have different formats for some

If you still need more performance, then I think you should go with one of the totally array approaches that others have suggested

Option Explicit
'     1       2      3    4            5                  6                   7                   8                      9                           10                             11
'Skill Group Date    ID  Calls   Avg Handle Time In  Avg Talk Time In    Avg Hold Time In    Avg Wrap Time In    Not Ready Time (Per Agent)  Logged On Time (Per Agent)  Available Time (Per Agent)
' 12  13      14         15             16           17          18            19           20          21            22                  23             24               25              26                  27                      28
'Day Month   Week    Week Beginning  Week Ending Agent Name  Team Manager    Location    SkillSet    Language    Total Handle Time   Total Talk Time Total Hold Time Total Wrap Time Not Ready Time(min) Logged On Time(min) Available Time(min)

Sub AddData()
    Dim rData As Range, rRow As Range, rNames As Range, rSkills As Range, rRoster As Range, rRoster1 As Range
    Dim i As Long
    Dim oWSF As WorksheetFunction
    Dim vIDs As Variant, vNames As Variant
    Dim vSkill As Variant, vSkills As Variant
    
    If Not TypeOf Selection Is Range Then Exit Sub
        
    Set oWSF = Application.WorksheetFunction
    
    Set rData = Worksheets("Data").Range("A1").CurrentRegion
    
    Set rNames = Worksheets("Mapping").Range("A1").CurrentRegion
    Set rNames = rNames.Cells(1, 2).Resize(rNames.Rows.Count, rNames.Columns.Count - 1) ' emp number is in A
    vIDs = oWSF.Transpose(rNames.Columns(1).Value)
    vNames = rNames.Value
    
    Set rSkills = Worksheets("Mapping").Range("I1").CurrentRegion
    vSkill = oWSF.Transpose(rSkills.Columns(1).Value)
    vSkills = rSkills.Value
    Application.ScreenUpdating = False
    
    For Each rRow In Intersect(Selection.EntireRow, rData).Rows
        With rRow
            If .Row = 1 Then GoTo GetNext
            If Len(.Cells(1).Value) = 0 Then GoTo GetNext
            
            For i = 12 To 28
                .Cells(i).Value = "-"
            Next I
              
            On Error Resume Next
            '  1      2    3      4           5               6
            'Date    Day Month   Week    Week Beginning  Week Ending
            .Cells(12).Value = Format(.Cells(2).Value, "DDDD")
            .Cells(13).Value = Format(.Cells(2).Value, "MMM-YY")
            .Cells(14).Value = "WK" & oWSF.WeekNum(.Cells(2).Value)
            .Cells(15).Value = "WB " & Format(.Cells(2).Value - oWSF.Weekday(.Cells(2).Value) + 1, "dd-mmm")
            .Cells(16).Value = "WE " & Format(.Cells(2).Value - oWSF.Weekday(.Cells(2).Value) + 7, "dd-mmm")
        
            '         1   2          3          4          5            6
            'EMP ID  ID  Name    Designation Supervisor  Location    Team Name
            i = oWSF.Match(.Cells(3).Value, vIDs, 0)
            .Cells(17).Value = vNames(i, 2)
            .Cells(18).Value = vNames(i, 4)
            .Cells(19).Value = vNames(i, 5)
        
            '    1            2         3        4             5
            'Skill_Name  Department  Product Skill_LOB   Skill_Language
            i = oWSF.Match(.Cells(1).Value, vSkill, 0)
            .Cells(20).Value = vSkills(i, 4)
            .Cells(21).Value = vSkills(i, 5)
        
            If .Cells(5).Value <> 0 Then .Cells(22).Value = .Cells(4).Value * .Cells(5).Value
            If .Cells(6).Value <> 0 Then .Cells(23).Value = .Cells(4).Value * .Cells(6).Value
            If .Cells(7).Value <> 0 Then .Cells(24).Value = .Cells(4).Value * .Cells(7).Value
            If .Cells(8).Value <> 0 Then .Cells(25).Value = .Cells(4).Value * .Cells(8).Value
            .Cells(26).Value = .Cells(9).Value / 600
            .Cells(27).Value = .Cells(10).Value / 60
            .Cells(28).Value = .Cells(11).Value / 60
            On Error GoTo 0
        
        End With
GetNext:
    Next
    'make roster worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Roster").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add.Name = "Roster"
    With rData
        .Columns(2).Copy Worksheets("Roster").Range("A1")
        .Columns(3).Copy Worksheets("Roster").Range("B1")
        .Columns(17).Copy Worksheets("Roster").Range("C1")
        .Columns(18).Copy Worksheets("Roster").Range("D1")
    End With
    
    Set rRoster = Worksheets("Roster").Range("A1").CurrentRegion
    With rRoster
        .EntireColumn.AutoFit
        Set rRoster1 = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
    End With
    
    With Worksheets("Roster").Sort
        .SortFields.Clear
        .SortFields.Add Key:=rRoster1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=rRoster1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rRoster
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub