excel - Save workbook to filepath based on user filepath location with first intial and last intial

Question

So currently the coding I did below works fine, but I would have to create lines of code for each individual. What I wanted was to reference cell ranges for the info to create the folder if not one already, save the file in each persons folder, but with initials and date

Cell D14:D24 with user(s) First Name and Last Name
Cell E14:E24 with user(s) intitals

---

' EoD Master Marco Code
' Created by Matthew
'''''''''''''''''''''''''''''''
Sub DateFolderSave()

Dim SuperUser               As String: SuperUser = Environ("username")
Dim MattFilePath            As String: MattFilePath = Environ("USERPROFILE") & "\Downloads\EoD Testing\Matt\"
Dim DavidFilePath           As String: DavidFilePath = Environ("USERPROFILE") & "\Downloads\EoD Testing\David\"
Dim ArtFilePath             As String: ArtFilePath = Environ("USERPROFILE") & "\Downloads\EoD Testing\Art\"
Dim strYear                 As String: strYear = Year(Date) & "\"
Dim strMonth                As String: strMonth = Format(Month(Date), "00") & "_" & MonthName(Month(Date)) & "\"
Dim strDay                  As String: strDay = Format(Date - Weekday(Date, 3), "dd.mm.yyyy") & "-" & Format(Date - Weekday(Date, 3) + 4, "dd.mm.yyyy") & "\"
Dim strFileName             As String: strFileName = "ATN EOD WK"

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
ThisWorkbook.CheckCompatibility = False

' Check for folder and create if needed
If Len(Dir(MattFilePath, vbDirectory)) = 0 Then
    MkDir MattFilePath
End If

' This will copy and paste cell value on Weekly Report
    Sheets("Weekly Report").Select
    Range("B14").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B14").Select
    
' This will update every sheet to reflect new date
' Will come back to this later to clean up
    
    Sheets("05.31A").Select
    Range("O1410").Select
    Sheets("05.31B").Select
    Range("X1611").Select
    Sheets("06.01A").Select
    Range("X1611").Select
    Sheets("06.01B").Select
    Range("Y1611").Select
    Sheets("06.02A").Select
    Range("Y1611").Select
    Sheets("06.02B").Select
    Range("Y1611").Select
    Sheets("06.03A").Select
    Range("Y1611").Select
    Sheets("06.03B").Select
    Range("Y1611").Select
    Sheets("06.04A").Select
    Range("Y1611").Select
    Sheets("06.04B").Select
    Range("Y1812").Select
    Sheets("06.05A").Select
    Range("Y1812").Select
    Sheets("06.05B").Select
    Range("Y1812").Select
    Sheets("06.06A").Select
    Range("O1611").Select

' Save File in Matt's Folder
ActiveWorkbook.SaveAs Filename:= _
MattFilePath & strFileName & Format(Sheets("Weekly Report").Range("C14"), " MM-DD") & "MV", _
FileFormat:=51, CreateBackup:=False

' Save File in Art's Folder
ActiveWorkbook.SaveAs Filename:= _
ArtFilePath & strFileName & Format(Now() + 6, " MM-DD") & "AM", _
FileFormat:=51, CreateBackup:=False

' Save File in David's Folder
ActiveWorkbook.SaveAs Filename:= _
DavidFilePath & strFileName & Format(Now() + 6, " MM-DD") & "DS", _
FileFormat:=51, CreateBackup:=False

ThisWorkbook.CheckCompatibility = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic

' Popup Message
MsgBox "Congrats: " & SuperUser & vbNewLine & "Files Saved in Leads Folders!"

End Sub

标签： excelvba