Excel macro gives different results when i run it and when my colleague runs it

Question

I've created a macro that splits data in a table based on a column in to new sheets. When it's been split it changes the headers from 1,2,3 and so on to what size that corresponds to in a table in the workbook. Last it removes any additional columns that i don't want to be in the new sheets that was created.

For me the Macro works perfectly every time but when my colleague runs it it doesn't work as expected. First it got the same data in both sheets and secondly it have removed more columns than it should. I have shared it with 2 other colleagues and for one it works as expected but the second one has the same issue as the first colleague i shared it with.

Below is the macro i'm using, i've separated the 3 parts of the macros with "-" so it's easier to see what is what.

Does anyone have an idea of why it gives 2 different results for different users? Just to add we got the same version of Excel.

Sub Splitdatabycol()

    'updateby Extendoffice
    
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWSTRg As Worksheet
    Dim xWS As Worksheet
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    
    Worksheets(3).Activate 'Tab to split
    
    Set xTRg = Range("1:1") 'Headers to include
    Set xVRg = Range("H:H") 'Split by column
    
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.AddressLocal
    titlerow = xTRg.Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    Application.DisplayAlerts = False
    
    If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then 'Checking so the worksheet doesn't exist
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" 'Adds a worksheet with a name xTRgWs_Sheet
    Else
        Sheets("xTRgWs_Sheet").Delete 'If the worksheet exists delete it
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" 'Adds a worksheet with a name xTRgWs_Sheet
    End If
    
    Set xWSTRg = Sheets("xTRgWs_Sheet")
    xTRg.Copy
    xWSTRg.Paste Destination:=xWSTRg.Range("A1")
    ws.Activate
    
    For i = (titlerow + xTRg.Rows.Count) To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
            xWS.Name = myarr(i) & ""
        Else
            xWS.Move after:=Worksheets(Worksheets.Count)
        End If
        
        xWSTRg.Range(title).Copy
        xWS.Paste Destination:=xWS.Range("A1")
        ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
        Sheets(myarr(i) & "").Columns.AutoFit
    Next
    
    xWSTRg.Delete
    ws.AutoFilterMode = False
    ws.Activate
    Application.DisplayAlerts = True

-----------------------------------------------------------------------------------------
    
    'Remove columns to make the data look nice
    
    Dim lColumn As Long
    Dim iCntr As Long
    Dim wb, y, f As Integer
    
    wb = ThisWorkbook.Sheets.Count
    y = 0
    f = 0
    lColumn = 220
    
    For y = wb To 4 Step -1
        Worksheets(y).Activate
        
        'Remove the buy index column
        
        If Range("A1") = "BUY INDEX" Then
                Columns("A").Delete
        End If

-----------------------------------------------------------------------------------------

        'Change size index to size description
        Range("I1").Select
        f = Range(Selection, Selection.End(xlToRight)).Columns.Count
        Range(Cells(1, 9), Cells(1, f)).Offset(0, f).Select
        Selection.Formula = _
        "=IFERROR(VLOOKUP($G2&""-""&I1,'Purchase grids'!$D:$I,6,0),"""")"
        Selection.Copy
        Range("I1").PasteSpecial Paste:=xlPasteValues

        'Remove excess columns without values

        For iCntr = lColumn To 1 Step -1
            If Trim(Cells(2, iCntr)) = “” Then
                Columns(iCntr).Delete
            End If
        Next
        
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
                
    Next
    
    Worksheets(2).Activate
    
    Application.ScreenUpdating = True
    
End Sub