VBA code to copy data over to separate templates

I have a work model which creates a number of templates of data on the tabs within the workbook, the working model works fine but i need to adapt the code to ask the user to select the template to copy the data too rather than copying it to the tabs in the workbook, once the data is copied to the template select by the user, the model will then prompt the user where to save the template.

The code i have is below;

Sub new_instruments()
   
    Const MYPASSWORD As String = "CRWT" 'pw to use for unprotect
    
    Dim xlWbActive  As Workbook     'Workbook which is active when code is started
    Dim xlWbNew     As Workbook     'Object for output workbooks
    Dim Sh          As Worksheet    'Worksheet to loop Worksheets Collection
    Dim xlRng       As Range        'Range used to find text on sheet
    Dim aData       As Variant      'contains table from "New Workings" sheet
    Dim aSheets     As Variant      'lists worksheets to save as separate workbooks
    Dim sSheetNames As String       'stores sheetnames when a new wb is created to remove them afterwards ("Sheet1","Sheet2",..)
    Dim sSaveAs     As String       'file location to be saved into
    Dim lngNextRow  As Long         'temporary, stores row number (usually lastrow +1)
    Dim i           As Long         'loop increment
    Dim j           As Long         'loop increment
    Dim k           As Long
    Dim tm          As Single       'stores starting time

    On Error GoTo new_instruments_ErrorHandler
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    'Start timer
    tm = Timer
    
    Set xlWbActive = ActiveWorkbook 'Workbook which is active when code is started
    
    'Unprotect passworded worksheets'
    For Each Sh In xlWbActive.Worksheets    'loop sheets
        Sh.Unprotect Password:=MYPASSWORD
    Next Sh
    
    With xlWbActive.Worksheets("Workings")
        lngNextRow = .Range("A" & .Rows.Count).End(xlUp).Row
        'Range of data to be used in Array
        aData = .Range("BF5:DZ" & lngNextRow).Value
    End With
    'Loop row matching
    For i = LBound(aData, 1) + 1 To UBound(aData, 1)
        'Check for existing tabs in workbook
        If WsExists(aData(i, 2), xlWbActive) Then
            CopyDataToSheet xlWbActive, aData, i
        Else
            With xlWbActive.Worksheets("Template Map")
                Set xlRng = .Columns(2).Find(What:=aData(i, 2), lookat:=xlWhole, LookIn:=xlValues)
                If Not xlRng Is Nothing Then
                    aData(i, 2) = xlRng.Offset(, -1).Value
                    If WsExists(aData(i, 2), xlWbActive) Then CopyDataToSheet xlWbActive, aData, i
                End If
            End With
        End If
    Next i
    
    'Delete aData memory
    Erase aData
    Set xlRng = Nothing

    'list of sheets to be saved into separate workbooks:
    aSheets = Array("CSH", "EQT", "EQT R & W", "Traded FUT", "Fixed Inc", "FND", "OTC Credit Default Derivatives", "OTC Options", "OTC Swaps")
    'let user specify save location:
    sSaveAs = Application.GetSaveAsFilename("[No Filename Needed - Just click Save]", "Excel Workbook (*.xlsx), *.xls,Excel 97-2003 Workbook (*.xls), *.xls")
    
    'if user did NOT click cancel button
    If sSaveAs <> "False" Then
        'loop sheetnames
        For i = LBound(aSheets) To UBound(aSheets)
            'check if sheet exists
            If WsExists(aSheets(i), xlWbActive) Then
                'remove duplicates:
                With xlWbActive.Worksheets(aSheets(i))
                    'find identifier col:
                    Set xlRng = .Rows(1).Find(What:="Identifier", LookIn:=xlValues, lookat:=xlWhole)
                    If xlRng Is Nothing Then Set xlRng = .Rows(1).Find(What:="User Identifier", LookIn:=xlValues, lookat:=xlWhole)
                    If xlRng Is Nothing Then Set xlRng = .Rows(1).Find(What:="Contract Code", LookIn:=xlValues, lookat:=xlWhole)
                    If xlRng Is Nothing Then
                        Select Case MsgBox("Cannot remove duplicates because no proper heading was found in '" & aSheets(i) & "'" & String(2, vbLf) & "OK: Continue with other sheets" & vbLf & "Cancel: Exit program", vbCritical + vbOKCancel, "Error")
                            Case vbOK
                                GoTo NextSheet
                            Case vbCancel
                                GoTo new_instruments_Proc_Exit
                        End Select
                    End If
                    'remove duplicates:
                    For k = .Cells(.Rows.Count, xlRng.Column).End(xlUp).Row To 2 Step -1
                        If Application.WorksheetFunction.CountIf(xlRng.EntireColumn, .Cells(k, xlRng.Column).Value) > 1 Then
                            .Rows(k).Delete Shift:=xlUp
                        End If
                    Next k
                End With
                'add new workbook to current application
                Set xlWbNew = Application.Workbooks.Add
                With xlWbNew
                    'reset variable that stores sheetnames from new workbook
                    sSheetNames = vbNullString
                    For Each Sh In .Worksheets
                    'store sheetnames from new workbook
                    sSheetNames = sSheetNames & ":" & Sh.Name
                    Next Sh
                    'copy worksheet to new workbook
                    xlWbActive.Worksheets(aSheets(i)).Copy After:=.Worksheets(.Worksheets.Count)
                    'remove not needed sheets from new book
                    For j = LBound(Split(sSheetNames, ":")) + 1 To UBound(Split(sSheetNames, ":"))
                        .Worksheets(Split(sSheetNames, ":")(j)).Delete
                    Next j
                    
                    'save new book as Excel binary
                    xlWbNew.SaveAs Left(sSaveAs, InStrRev(sSaveAs, "\")) & aSheets(i) & ".xlsx", xlExcel12
                    'close new workbook
                    xlWbNew.Close True
                    
                End With
            Else
                'if sheet to be exported does not exist inform user, is user clicks cancel the macro stops
                If vbCancel = MsgBox("Worksheet '" & aSheets(i) & "' not found!", vbOKCancel + vbInformation, "Title") Then GoTo new_instruments_Proc_Exit
            End If
NextSheet:
        Next i
    End If
    
     'Identify time taken
    With xlWbActive.Sheets("Start")
        .Range("N23").Value = Format(Now, "dd-mmm-yy (HH:MM)")
        .Range("N24").Value = UCase(Environ("username")) & " on PC " & UCase(Environ("computername"))
        .Range("N25").Value = Format(Now - tm, "HH:MM:SS")
        .Activate
    End With
    
    'Update activity log with this step
action_type = "New Instruments Macro"
Call activity_log

    
new_instruments_Proc_Exit:
    MsgBox "Complete in " & Format(Round(Timer - tm, 3), "00:00:00.000") & " seconds", vbOKOnly + vbInformation, "Done"
    On Error GoTo 0
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    Exit Sub
new_instruments_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'new_instruments' of Module 'Module1'.", vbOKOnly + vbCritical, "Error"
    Resume new_instruments_Proc_Exit
End Sub

Sub CopyDataToSheet(xlWbActive As Workbook, aData, i As Long)
    Dim xlRng As Range
    Dim lngNextRow As Long, j As Long
    
    With xlWbActive.Worksheets(aData(i, 2))
        'Find the next blank row
        lngNextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        'Loop the column matching
        For j = LBound(aData, 2) + 2 To UBound(aData, 2)
            'Find Matching column
            Set xlRng = .Rows(1).Find(What:=aData(1, j), LookIn:=xlValues, lookat:=xlWhole)
            'Copying data if there is a macthing column
            If Not xlRng Is Nothing Then
                'Copy Data'
                .Cells(lngNextRow, xlRng.Column).Value = aData(i, j)
            End If
        Next j
    End With
End Sub

'Check weather worksheet with wsName exsists in Workbook
Function WsExists(ByVal wsName, Optional xlWb As Excel.Workbook) As Boolean
    On Error GoTo ErrHandler
    If TypeName(wsName) <> "String" Then GoTo ErrHandler
    Dim sTmp$
    'If no object provided then use the active workbook
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    sTmp = xlWb.Worksheets(wsName).Name
    'If the sheet does not exist then jump to ErrHandler
    WsExists = True
    Exit Function
'When a sheet does not exist
ErrHandler:
    WsExists = False
End Function

Apologies, this is no longer needed - could a moderator deleted this thread?

My apologies for the setup in error.