Xin giúp đỡ macro tách file theo cột

Sub TachLop()
    Dim xRCount As Long
    Dim xSht As Worksheet
    Dim xNSht As Worksheet
    Dim I As Long
    Dim xTRrow As Integer
    Dim xCol As New Collection
    Dim xTitle As String
    Dim xSUpdate As Boolean
    Set xSht = ActiveSheet
    Call XoaSheet
    On Error Resume Next
    xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
    xTitle = "A1:E1"
    xTRrow = xSht.Range(xTitle).Cells(3).Row
    For I = 2 To xRCount
        Call xCol.Add(xSht.Cells(I, 3).Text, xSht.Cells(I, 3).Text)
    Next
    xSUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    For I = 1 To xCol.Count
        Call xSht.Range(xTitle).AutoFilter(3, CStr(xCol.Item(I)))
        Set xNSht = Nothing
        Set xNSht = Worksheets(CStr(xCol.Item(I)))
        If xNSht Is Nothing Then
            Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
            xNSht.Name = CStr(xCol.Item(I))
        Else
            xNSht.Move , Sheets(Sheets.Count)
        End If
        xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
        xNSht.Columns.AutoFit
    Next
    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate
End Sub

Dim Col As Integer
Dim Arr(1 To 299, 1 To 7)
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim sArr()
 Dim J As Long, Rws As Long, Cot As Byte, W As Integer
 
 If Not Intersect(Target, [L1]) Is Nothing Then
    With Sheets("GPE")
        If Left(Target.Value, 1) = "L" Then
            .Range("A2:A37").Copy Destination:=.[d2]
            .[k2:K3].Value = .[L2:L3].Value
             [L2].Value = Space(o):                     Col = 5
        ElseIf Left(Target.Value, 1) = "M" Then
            .[k2:K3].Value = .[M2:m3].Value
            .Range("Diem").Copy Destination:=.[d2]
        End If
    End With
 ElseIf Not Intersect(Target, [L2]) Is Nothing Then
    If Left(Target.Value, 1) = "T" Then
        Col = 6
    ElseIf Left(Target.Value, 1) = "V" Then
        Col = 7
    End If
 ElseIf Not Intersect(Target, [L3]) Is Nothing Then
    [A6:G300].Value = ""
    If Col Then
        With Sheets("HSHS")
            Rws = .[A2].CurrentRegion.Rows.Count
            sArr() = .[A2].Resize(Rws, 7).Value
        End With
        For J = 1 To UBound(sArr())
            If sArr(J, Col) = Target.Value Then
                W = W + 1:              Arr(W, 1) = W
                For Cot = 2 To 7
                    Arr(W, Cot) = sArr(J, Cot)
                Next Cot
            End If
        Next J
        If W Then
            [a6].Resize(W, 7).Value = Arr()
        End If
    End If
 End If
End Sub