Split the worksheets in two different Floders

[Nithya]

Hi ,

I'm new here.
I have a questions that i could not find the answer yet.
I'm also new in macro VBA programming.

I have a xls sheet with 5 tabs, I need to delete all the tabs except the two tabs which are Event tab and Occurrence Tab.( I have a macro which is working fine till this part).i.e it is deleting the remaining three tabs.

Now What I want to do is

1) The macro should read the source files( I have around 1000 files), the source files will be in C:\Uploaded
2) The macro should delete all the tabs except events and occurrence tab and the macro should place the event tab in c:\event and occurrence tab in c:\occurrence folder,


Below is the code which I am currently using two times in each folder.

Sub WorksheetDeletionMacro()
    
    Dim strFldrPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        On Error GoTo ExitSub
        strFldrPath = .SelectedItems(1)
    End With

    Dim CurrentFile As String: CurrentFile = Dir(strFldrPath & "\" & "*.xls")
    Dim SheetName As String:   SheetName = "Event"
    Dim FailedWorkbooks As String: FailedWorkbooks = vbNullString
    Dim wb As Workbook, ws As Worksheet
    Application.ScreenUpdating = False
    While CurrentFile <> vbNullString
        Set wb = Workbooks.Open(strFldrPath & "\" & CurrentFile)
        If SheetExists(SheetName, wb) Then
            Application.DisplayAlerts = False
            For Each ws In wb.Sheets
                If ws.Name <> SheetName Then ws.Delete
            Next ws
            Application.DisplayAlerts = True
        ElseIf FailedWorkbooks = vbNullString Then
            FailedWorkbooks = wb.Name
        Else
            FailedWorkbooks = FailedWorkbooks & ", " & wb.Name
        End If
        wb.Close True
        CurrentFile = Dir
    Wend
    Application.ScreenUpdating = True
    
    If FailedWorkbooks <> vbNullString Then MsgBox FailedWorkbooks & " did not have a sheet named " & SheetName & "."
    Exit Sub
    
ExitSub:
    Exit Sub
    
End Sub

Private Function SheetExists(SheetName As String, wb As Workbook) As Boolean
    
    Dim wsCheck As Worksheet
    On Error GoTo NotFound
    Set wsCheck = wb.Sheets(SheetName)
    SheetExists = True
    Exit Function
    
NotFound:
    SheetExists = False
    
End Function

Please help me with a logic for this.