[Tasos]

Καλησπέρα Δημήτρη!
Όσον αφορά το θέμα επιδόσεων, η Excel 2013 είναι σαφώς καλύτερη με την προϋπόθεση ότι ο κώδικας VBA είναι γραμμένος από χρήστη που έχει γνώσεις του αντικειμένου αυτοματοποίησης της Excel.

Δοκίμασε τον παρακάτω κώδικα (με βάση το συνημμένο που ανέβασες εδώ: http://www.ms-office.gr/forum/excel-...ct-values.html ).

Option Explicit

Sub Test()
    Dim LastRow As Long
    Dim rngTarget As Range
    Dim rngTargetKW As Range
    Dim rngSource As Range
    Dim c As Range
    Dim wb As Workbook
    Dim wksSource As Worksheet
    Dim wksTarget As Worksheet
    Dim WF As WorksheetFunction
    Dim i As Long
    Dim KW As Integer
    Dim dtDate As Date

    On Error GoTo ExitHere

    Set WF = Application.WorksheetFunction

    Set wksTarget = ThisWorkbook.Worksheets("KW_Auswahl")
    With wksTarget
        .Range("A2:E" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
        .Range("A1").Value = "KW_LJCombiNr"
        .Range("B1").Value = "Check"
        .Range("C1").Value = "KW"
        .Range("D1").Value = "Count"
        .Range("E1").Value = "Date"
    End With
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .ShowWindowsInTaskbar = False
    End With
    Set wb = Workbooks.Open("C:\Users\Admin\Desktop\ItemsPerWeek.xlsx", ReadOnly:=True)    ' Προσάρμοσε τη διαδρομή του αρχείου
    Set wksSource = wb.Worksheets("Item List")
    LastRow = wksSource.UsedRange.Rows.Count
    With wksSource.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wksSource.Range( _
                             "C2:C" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                        xlSortNormal
        .SortFields.Add Key:=wksSource.Range( _
                             "B2:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                        xlSortNormal
        .SetRange wksSource.Range("A1:E" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    LastRow = wksSource.Cells(wksSource.Rows.Count, 4).End(xlUp).Row
    Set rngSource = wksSource.Range("A2:E" & LastRow)
    rngSource.RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
    LastRow = wksSource.Cells(wksSource.Rows.Count, 4).End(xlUp).Row
    Set rngSource = wksSource.Range("B2:B" & LastRow)

    Set rngTarget = wksTarget.Range("A2:A" & LastRow)
    Set rngTargetKW = rngTarget.Offset(, 2)
    For Each c In rngSource
        i = i + 1
        KW = c.Value
        dtDate = c.Offset(, 1).Value
        rngTarget(i).Value = Format(KW) & " - " & Format(dtDate, "dd.MM.yyyy")
        rngTarget(i).Offset(, 1).Value = c.Value > 0
        If c.Value > 0 Then rngTarget(i).Offset(, 2).Value = c.Value
        rngTarget(i).Offset(, 3).Value = WF.CountIf(rngTargetKW, KW)
        rngTarget(i).Offset(, 4).Value = dtDate
    Next
ExitHere:
    If Err <> 0 Then
        MsgBox "Σφάλμα: " & Err.Number & vbLf & Err.Description, vbExclamation
    End If
    If Not wb Is Nothing Then
        wb.Close False
        Set wb = Nothing
    End If
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .ShowWindowsInTaskbar = True
    End With

End Sub

Καλή συνέχεια!

Τάσος