[kapetang]

Καλημέρα

Άλλαξε τον κώδικα με τον παρακάτω:

Public Sub POSITIONS()
    Dim rng As Range, i As Long, c As Variant
    Dim cat As Variant, S As Shape, str As String
    cat = Array("GK", "DF", "MF", "AT")

    Application.ScreenUpdating = False

    'Διαγραφή παλιών φύλλων
    On Error Resume Next
    Application.DisplayAlerts = False
    For Each c In cat
        Worksheets(c).Delete
    Next
    Application.DisplayAlerts = False
    On Error GoTo 0



    'Δημιουργία φύλλων και πινάκων
    For Each c In cat
        Sheets("EVALUATION").Copy after:=Sheets(Sheets.Count)

        With ActiveSheet
            For Each S In .Shapes
                If S.TopLeftCell.Column >= 5 Then
                    S.Name = S.TopLeftCell.Address(0, 0, xlA1)
                End If
            Next
            .Name = c
            Set rng = .Range("e13", .Cells(13, Cells.Columns.Count).End(xlToLeft))

            For i = rng.Columns.Count To 1 Step -1
                If rng(i) <> c Then
                    str = rng(i).Offset(-9).Address(0, 0, xlA1)
                    On Error Resume Next
                    .Shapes(str).Delete
                    On Error GoTo 0
                    rng(i).EntireColumn.Delete
                End If
            Next
        End With
    Next
    
    Worksheets("PLAYERSTATS").Activate
    FILLPLAYERSTATS
End Sub

1) Για να εμφανίζονται σωστά οι φωτογραφίες κάθε μία στο φύλλο EVALUATION θα πρέπει να περιέχεται πλήρως μέσα στο αντίστοιχο κελί.

2) Για το φύλλο PLAYERSTATS πιθανόν να χρειαστεί κάποια τροποποίηση της μακροεντολής FILLPLAYERSTATS.