Save files to a Mapped Network Drive on server

The following VBA is to name and save multiple files to a mapped network drive on a server. I have the code working when saving locally, however when saving to the mapped network drive, my files keep saving to a default directory rather than the specified location. I have read/write permissions for the network drive.

Thanks in advance...

With ThisWorkbook

    Dim newFile1 As String, fName1 As String, newFile2 As String, fName2 As String, newFile3 As String, fName3 As String, newFile4 As String, fName4 As String, newFile5 As String, fName5 As String, newFile6 As String, fName6 As String
    fName1 = Range("=LISTS!A1").Value
    fName2 = Range("=LISTS!A2").Value
    fName3 = Range("=LISTS!A3").Value
    fName4 = Range("=LISTS!A4").Value
    fName5 = Range("=LISTS!A5").Value
    fName6 = Range("=LISTS!A6").Value
    
    newFile1 = fName1
    newFile2 = fName2
    newFile3 = fName3
    newFile4 = fName4
    newFile5 = fName5
    newFile6 = fName6
     ' Change directory to suit your PC, including USER NAME
    ChDir _
    "Z:\Individual_Files"
    ActiveWorkbook.SaveAs Filename:=newFile1, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=newFile2, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=newFile3, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=newFile4, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=newFile5, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=newFile6, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = False
 
End With

You don't need chdir.
This is all you need (provided cells A1:A5 contain valid Workbooknames, including extensions.

Sub snb()
  for j=1 to 5
    thisworkbook.savecopyas "Z:\Individual_files\" & sheets("Lists").cells(j,1)
  next
end sub

I would go with kyle on this one

Declare Function WNetGetConnectionA Lib "mpr.dll" _
                                    (ByVal lpszLocalName As String, _
                                     ByVal lpszRemoteName As String, _
                                     cbRemoteName As Long) As Long
                                     Dim flag
                                     


Function GetUNCPath(myDriveLetter As String) As String

    Dim lReturn As Long
    Dim szBuffer As String

    myDriveLetter = Left(myDriveLetter, 1) & ":"

    szBuffer = String$(256, vbNullChar)
    lReturn = WNetGetConnectionA(myDriveLetter, szBuffer, 256)

    If lReturn = 0 Then
        GetUNCPath = Left$(szBuffer, InStr(szBuffer, vbNullChar))

    Else
        GetUNCPath = "Invalid drive"
        flag = "No"
    End If

End Function

Sub test1()
 Dim letdrive As String
 'get active name
    namfile = ActiveWorkbook.FullName
 'isolate drive letter
    howlong = Len(namfile)
    nameonly = Right(namfile, (howlong - 2))
 'drive letter
    letdrive = Left(namfile, 1)
 'get server name path
    getuncpath1 = GetUNCPath(letdrive)
 'remove 2 special character last
    lenserver = Len(getuncpath1)
    servername = Left(getuncpath1, (lenserver - 2))
 'assemble new name
    getfullservername = servername & nameonly
 'display
     MsgBox getfullservername

End Sub