Problems with VBA

Question

This will look for current year and month folder problem one is it keeps cresting the 2 folders over and over again, Also would like for it to save the file with the value of a cell like if I put address in it would save in the current month file with address in say cell A1

Sub SaveCopyofWorkbook2()

Dim FilePath As String '

Dim FolderObj As Object '

On Error GoTo LeverageLean

Application.DisplayAlerts = False 'Hide Display Alerts

FilePath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) & Format(Date, "YYYY") 'Active Workbook File Path and Current Year Folder

Set FolderObj = CreateObject("Scripting.FileSystemObject")

If FolderObj.FolderExists(FilePath) Then 'The Folder has been found

Else: FolderObj.CreateFolder (FilePath) 'The Folder has been created

End If

FilePath = FilePath & "" & Format(Date, "MMMM") 'File Path and Current Month Folder

Set FolderObj = CreateObject("Scripting.FileSystemObject")

If FolderObj.FolderExists(FilePath) Then 'The Folder has been found

Else: FolderObj.CreateFolder (FilePath) 'The Folder has been created

End If

Application.ActiveWorkbook.SaveAs FileName:=FilePath & "" & Sheets("Sheet1").Range("A1").Value & Right(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) + 1) - InStrRev(ActiveWorkbook.FullName, ".")) 'Save copy to Active Workbook File Path\Current Year\Current Month\Current Date & Time

MsgBox "A copy of this Active Workbook named """ & Format(Date, "MM.DD.YYYY") & Right(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) + 1) - InStrRev(ActiveWorkbook.FullName, ".")) & """ has been saved to the following location:" & vbNewLine & vbNewLine & Left(FilePath, InStr(1, ActiveWorkbook.FullName, ActiveWorkbook.Name) - 1)

Exit Sub

LeverageLean: MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider@leveragelean.com") End Sub