LinkBack URL
About LinkBacks
I have a macro and part of it let's the user select where to save the file. It worked fine a few hours ago, buy suddenly stopped working. It nows saves to the folder just above the folder selected. Ex saves to C:My Docs instead of C : My Docs\Files. Can someone please assist?
This is the part I'm having a problem with:
This is the entire macro
'Save document as current month Dim strFolder As String Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .Title = "Select the folder into which the documents will be saved." ActiveWorkbook.SaveAs s_dir & Format(Date, "mmmyyyy") & Range("A1").Value, FileFormat:=51, CreateBackup:=False If .Show = -1 Then strFolder = .SelectedItems(1) & "\" Else MsgBox "The documents will be saved in the default document file location." strFolder = "" End If End WithSub FinalizeWorkbook() 'copy and paste all values Dim OldSelection As Range Dim HiddenSheets() As Boolean Dim Goahead As Integer, n As Integer, i As Integer Goahead = MsgBox("This will irreversibly convert all formulas in the workbook to values. Continue?", vbOKCancel, "Confirm conversion to values only") If Goahead = vbOK Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual n = Sheets.Count ReDim HiddenSheets(1 To n) As Boolean For i = 1 To n If Sheets(i).Visible = False Then HiddenSheets(i) = True Sheets(i).Visible = True Next Set OldSelection = Selection.Cells Worksheets.Select Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues Cells(OldSelection.Row, OldSelection.Column).Select Sheets(OldSelection.Worksheet.Name).Select Application.CutCopyMode = False For i = 1 To n Sheets(i).Visible = Not HiddenSheets(i) Next Application.Calculation = xlCalculationAutomatic End If 'Delete instruction worksheets Dim vaNames As Variant Application.DisplayAlerts = False vaNames = Array("Forecast Instructions", "START HERE ", "Forecast Template", "Forecast Comments", "BU Pull", "Adhoc Reporting", "START HERE* (2)", "Summary", "Pull", "START HERE") Worksheets(vaNames).Delete Application.DisplayAlerts = True 'Copy Tab Names Dim ws As Worksheet For Each ws In Sheets With ws .Range("B11").Cut Destination:=.Range("A13") End With Next ws 'Create new worksheet Worksheets.Add().Name = "Master" 'Merge all worksheets Sheets(1).Activate lastrow = ActiveSheet.UsedRange.Rows.Count For Each Sheet In Sheets If Sheet.Index <> 1 Then RowCount = Sheet.UsedRange.Rows.Count Sheet.UsedRange.Copy Destination:=Sheets(1).Cells(lastrow + 1, 1) lastrow = lastrow + RowCount Sheet.UsedRange.Clear End If Next Sheet 'Delete worksheets except "Master" Dim Sh As Worksheet Application.DisplayAlerts = False For Each Sh In Worksheets If*Sh.Name*<>*ActiveSheet.Name*Then Sh.Delete Next Sh Application.DisplayAlerts = True ActiveWindow.View = xlNormalView 'Unhide all columns and cells Cells.Select Selection.EntireColumn.Hidden = False Selection.EntireRow.Hidden = False 'Copy entity to different cell Range("B11").Select Selection.Cut Destination:=Range("B13") Rows("1:12").Select *** Selection.Delete Shift:=xlUp 'Delete unused information Columns("A:A").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete Columns("C:C").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete Columns("B:B").Select Selection.EntireColumn.Delete 'Copy entity name to column B Columns("B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove Range("B1").Select ActiveCell.FormulaR1C1 = "=IF(LEFT(RC[-1],1)=""E"",RC[-1],""DELETE"")" 'Fill cells with correct entity name Selection.AutoFill Destination:=Range("B1:B5000") Range("B1:B4701").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Cells.Replace What:="DELETE", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False 'Paste column entity name as values Columns("B:B").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" Columns("B:B").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Delete extra columns Columns("AY:BY").Select Selection.EntireColumn.Delete 'Delete named ranges Dim nm As Name On Error Resume Next For Each nm In ActiveWorkbook.Names nm.Delete Next On Error GoTo 0 'Save document as current month Dim strFolder As String Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .Title = "Select the folder into which the documents will be saved." ActiveWorkbook.SaveAs s_dir & Format(Date, "mmmyyyy") & Range("A1").Value, FileFormat:=51, CreateBackup:=False If .Show = -1 Then strFolder = .SelectedItems(1) & "\" Else MsgBox "The documents will be saved in the default document file location." strFolder = "" End If End With 'Create Archive file if one doesn't exist Dim Rslt Rslt = Split(CurDir, Application.PathSeparator) If Dir(CurDir & Application.PathSeparator & "Forecast Archive.xlsx") <> "" Then MsgBox "File is present" Else Workbooks.Add Worksheets.Add().Name = "Do Not Modify" ActiveWorkbook.SaveAs "Forecast Archive.xlsx", FileFormat:=51 Workbooks("Forecast Archive.xlsx").Close End If 'Copy sheet to archive file Workbooks.Open Filename:="Forecast Archive.xlsx" ActiveWindow.ActivatePrevious Sheets("Master").Select Sheets("Master").Copy After:=Workbooks("Forecast Archive.xlsx").Sheets(1) ActiveSheet.Name*= Format(Date, "mmmyyyy") ActiveWindow.ActivatePrevious Cells.Select Range("A1").Activate Selection.Copy Windows("Forecast Archive.xlsx").Activate Sheets("DO NOT MODIFY").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveWorkbook.Save ActiveWindow.Close Application.ScreenUpdating = True End Sub
Register To Reply
Bookmarks