snuffnchess
Board Regular
- Joined
- May 15, 2015
- Messages
- 68
- Office Version
- 365
- Platform
- Windows
I am getting a "Run-time error '1004': Method 'SaveAs' of object'_Workbook' failed" message when this macro goes to save a new workbook with pasted information in it.
In using a msgbox to verify the path of "sfile", all of the naming is correct. But Im at a loss for why I keep getting the error. When the error is on the screen - I can see that the file saved to the directory that it was supposed to via File Explorer. If I click debug the line that it shows the error to be on is "nwb.SaveAs Filename:=sfile, FileFormat:=51", and if I try to keep the macro going past it, I get error "Document not saved."
Any thoughts?
In using a msgbox to verify the path of "sfile", all of the naming is correct. But Im at a loss for why I keep getting the error. When the error is on the screen - I can see that the file saved to the directory that it was supposed to via File Explorer. If I click debug the line that it shows the error to be on is "nwb.SaveAs Filename:=sfile, FileFormat:=51", and if I try to keep the macro going past it, I get error "Document not saved."
Any thoughts?
VBA Code:
Sub mformat()
Dim ob As Workbook
Dim ob1 As Workbook
Dim ob2 As Workbook
Dim ob3 As Workbook
Dim ob4 As Workbook
Dim nwb As Workbook
Dim nws As Worksheet
Dim marc As Worksheet
Dim marp As Worksheet
Dim flist As Worksheet
Dim indata As Worksheet
Dim marclr As Long
Dim marplr As Long
Dim flistclr As Long
Dim flistplr As Long
Dim fldr As FileDialog
Dim strPath As String
Dim strDir As String
Dim strWe As String
Dim strDirc As String
Dim strDirp As String
Dim sfile As String
Dim rec1 As Variant
Dim rec2 As Variant
Dim rec3 As Variant
Dim rec4 As Variant
Dim sdatec As Variant
Dim edatec As Variant
Dim sdatep As Variant
Dim edatep As Variant
Dim wedate As Variant
Dim i As Long
Dim j As Long
Set ob = ThisWorkbook
Set indata = ob.Sheets("Input")
Set marc = ob.Sheets("MarginC")
Set marp = ob.Sheets("MarginP")
Set flist = ob.Sheets("FranList")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
marc.Cells.ClearContents
marp.Cells.ClearContents
flist.Cells.ClearContents
rec1 = Application.GetOpenFilename(Title:="Select First Current Margin File", FileFilter:="Excel Files (*.xls*; *.csv),*.xls*; *.csv")
If rec1 <> False Then
Set ob1 = Application.Workbooks.Open(rec1)
With ob1.Sheets(1).UsedRange
.Resize(.Rows.Count, .Columns.Count - 2).Offset(0, 2).Copy
End With
marc.Range("A1").PasteSpecial xlPasteValues
ob1.Close False
End If
rec2 = Application.GetOpenFilename(Title:="Select Second Receivables File", FileFilter:="Excel Files (*.xls*; *.csv),*.xls*; *.csv")
If rec2 <> False Then
Set ob2 = Application.Workbooks.Open(rec2)
With ob2.Sheets(1).UsedRange
.Resize(.Rows.Count - 1, .Columns.Count - 2).Offset(1, 2).Copy
End With
marc.Activate
With marc
marclr = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & marclr).PasteSpecial xlPasteValues
.Range("A1").Select
End With
ob2.Close False
End If
rec3 = Application.GetOpenFilename(Title:="Select First Previous Margin File", FileFilter:="Excel Files (*.xls*; *.csv),*.xls*; *.csv")
If rec3 <> False Then
Set ob3 = Application.Workbooks.Open(rec3)
With ob3.Sheets(1).UsedRange
.Resize(.Rows.Count, .Columns.Count - 2).Offset(0, 2).Copy
End With
marp.Range("A1").PasteSpecial xlPasteValues
ob3.Close False
End If
rec4 = Application.GetOpenFilename(Title:="Select Second Previous File", FileFilter:="Excel Files (*.xls*; *.csv),*.xls*; *.csv")
If rec4 <> False Then
Set ob4 = Application.Workbooks.Open(rec4)
With ob4.Sheets(1).UsedRange
.Resize(.Rows.Count - 1, .Columns.Count - 2).Offset(1, 2).Copy
End With
marp.Activate
With marp
marplr = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & marplr).PasteSpecial xlPasteValues
.Range("A1").Select
End With
ob4.Close False
End If
' sdatec = InputBox("Enter Start Date for Current Data in mm/dd/yyyy format")
' indata.Range("H1").Value = sdatec
' indata.Range("H1").NumberFormat = "mm/dd/yyyy"
'
' edatec = InputBox("Enter End Date for Current Data in mm/dd/yyyy format")
' indata.Range("L1").Value = edatec
' indata.Range("L1").NumberFormat = "mm/dd/yyyy"
'
' sdatep = InputBox("Enter Start Date for Previous Data in mm/dd/yyyy format")
' indata.Range("H2").Value = sdatep
' indata.Range("H2").NumberFormat = "mm/dd/yyyy"
'
' edatep = InputBox("Enter End Date for Previous Data in mm/dd/yyyy format")
' indata.Range("L2").Value = edatep
' indata.Range("L2").NumberFormat = "mm/dd/yyyy"
'
wedate = InputBox("Enter Week End Date in mm/dd/yyyy format")
indata.Range("B1").Value = wedate
indata.Range("B1").NumberFormat = "mm/dd/yyyy"
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to save Files to"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then Exit Sub
strDir = .SelectedItems(1)
End With
indata.Range("A5").Value = strDir
marc.Activate
marclr = Cells(Rows.Count, "A").End(xlUp).Row
marc.Range("A2:A" & marclr).AdvancedFilter Action:=xlFilterCopy, copytorange:=flist.Range("A1"), Unique:=True
marp.Activate
marplr = Cells(Rows.Count, "A").End(xlUp).Row
marp.Range("A2:A" & marplr).AdvancedFilter Action:=xlFilterCopy, copytorange:=flist.Range("F1"), Unique:=True
flist.Range("A1").Value = "Current Listing"
flist.Range("F1").Value = "Previous Listing"
flist.Columns.AutoFit
flist.Activate
flistclr = Cells(Rows.Count, "A").End(xlUp).Row
flistplr = Cells(Rows.Count, "F").End(xlUp).Row
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:A" & flistclr)
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("F1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("F1:F" & flistplr)
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
strWe = strDir & "\" & format(wedate, "yyyy-mm-dd") & "\"
'strDirc = strWe & "\Current\"
'strDirp = strWe & "\Previous\"
If Len(Dir(strWe, vbDirectory)) = 0 Then
MkDir strWe
'MkDir strDirc
'MkDir strDirp
End If
For i = 2 To flistclr
sfile = strWe & flist.Range("A" & i).Value & " - " & format(wedate, "yyyy-mm-dd") & ".xlsx"
Set nwb = Workbooks.Add
Set nws = nwb.Worksheets(1)
marc.Range("A1:Q" & marclr).AutoFilter Field:=1, Criteria1:=flist.Range("A" & i).Value
marc.Range("A1:Q" & marclr).SpecialCells(xlCellTypeVisible).Copy
nws.Range("A1").PasteSpecial
MsgBox sfile
nwb.SaveAs Filename:=sfile, FileFormat:=51
nwb.Close False
Next i
'For j = 2 To flistplr
' sfile = strWe & flist.Range("F" & j).Value & " Repulled Margin WE " & format(wedate, "yyyy-mm-dd")
' Set nwb = Workbooks.Add
' Set nws = nwb.Worksheets(1)
'
' marp.Range("A1:Q" & marplr).AutoFilter Field:=1, Criteria1:=flist.Range("A" & i).Value
' marp.Range("A1:Q" & marplr).SpecialCells(xlCellTypeVisible).Copy
'
' nws.Range("A1").PasteSpecial
'
' nwb.SaveAs Filename:=sfile, FileFormat:=51
' nwb.Close False
'Next j
indata.Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
