Help with Amending VBA code that splits data by column

[Fuisdale2]

Hi all,

I have a really disgusting piece of VBA code and I apologise now to those that look at the code in disgust.

I am trying to get the code to loop through all files in the folder and perform the VBA code and it opens the file and then fails to perform anything.

Please can you help in anyway !!

Sub SPLIT_WORKBOOK()
Dim folderPath As String
folderPath = ThisWorkbook.Path & "\"
            
Filename = Dir(folderPath & "*.xlsx")
    
Do While Filename <> ""
    Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
    For Each sh In wb.Sheets
       
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
'code to seletct row
    ActiveWorkbook.Activate
'code above
vcol = 4
Set ws = Sheets("Sheet1")
ActiveSheet.Select
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:L5"
titlerow = ws.Range(title).Cells(1).Row
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "SEL"
For i = 3 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)
'CODE THATS BUGGING I THINK
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=Array( _
        "Category", "DST", "Store"), Operator:=xlFilterValues
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
'SECOND ZACK CODE
vcol = 4
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:L5"
titlerow = ws.Range(title).Cells(1).Row
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "DST"
For i = 3 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)
'CODE THATS BUGGING I THINK
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=Array( _
        "Category", "SEL", "Store"), Operator:=xlFilterValues
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate

'DELETE NON REQUIRED WORKSHEETS
Application.DisplayAlerts = False
    Sheets(Array("Store", "Category")).Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    
    Next
    wb.Close False
    Filename = Dir
    Set wb = Nothing
Loop
End Sub