I'm saving a workbook as a copy with date.
I did it with the code suggested on this site (save as copy).
Now I'm getting an error concerning the links in my new workbook. Is there a way to set the correct links (on the new workbook) to the new workbook together with the save as copy method?
Sub Button15_Click()
ActiveWorkbook.Save
'https://stackoverflow.com/questions/18899824/how-to-use-vba-saveas-without-closing-calling-workbook
'SaveAsCopy
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo Whoa
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
On Error GoTo 0
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(1)
Next
wbTemp.Sheets(1).Delete
'wbTemp.SaveAs "C:\Users\Me\Desktop\FileName & Format(CStr(Now), dd-mm-yy-hhumm).xlsm", 52 'Save as timestamp
wbTemp.SaveAs ("C:\Users\Me\Desktop\") & "FileName" & Format(Now, "dd-mm-yy-hhumm") & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
LetsContinue:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Related
I have a template file and 4 source documents that I use to fill the template. For each row in sheet2, I create a new blank template and fill it out, resulting in somewhere between 10-100 files. I want to save these in a loop, but having issues with Excel force closing on me. This is my code so far, recycled from a different project.
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
Dim folderName As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
folderName = Format(Date, "ddmmyyyy")
'set path to save
'fp = "<PATH HERE>" & folderName
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\ThisProject\csvOutput\" & folderName
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder (fp)
End If
'cycle through each of the worksheets
For w = 6 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add after:=Sheets(Sheets.Count)
Range("A1").Select
ActiveSheet.Paste
Worksheets(1).Delete
Worksheets(1).Name = fn
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub ```
The code below worked for me: not sure exactly where the problem might vbe with your posted code, but within your With blocks not everything is scope to the block using a leading .
Sub Test()
Dim w As Long, wb As Workbook, wbNew As Workbook
Dim fp As String, fn As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
Set wb = ThisWorkbook
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\" & _
"ThisProject\csvOutput\" & Format(Date, "ddmmyyyy") & "\"
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder fp
End If
'cycle through each of the worksheets
For w = 6 To wb.Worksheets.Count
'explicitly create a new single-sheet workbook as the destination
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet)
wb.Worksheets(w).Copy before:=wbNew.Sheets(1)
DeleteSheet wbNew.Sheets(2)
With wbNew
fn = .Worksheets(1).Name
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
.Worksheets(1).Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Worksheets(2).Range("A1")
DeleteSheet .Worksheets(1)
.Worksheets(1).Name = fn
.SaveAs Filename:=fp & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
Next w
Exit Sub
bm_Safe_Exit:
MsgBox Err.Description
End Sub
'utility sub
Sub DeleteSheet(ws As Worksheet)
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
I've got a workbook where I am creating a button that allows to save two specific sheets without formula's (the purpose being that the sheets are going to be send to partners and costumers). I would like the sheets to be saved in a single document somewhere on my computer, and still have the current "design" with colors, setup etc.
I've currently written this code, which does everything that I've described, except deleting the formulas...
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Hope you can help :-)
I have a sheet I use something similar for, I'll adjust the code a bit to work with your scenario. If you don't want the settings to change, delete the TurnOnFunctions & TurnOffFunctions subs.
This code will only break the links, not necessarily all the formulas. So if a formula references another spreadsheet it will be a static value; however, if it is a simple formula that stays within the spreadsheet it will stay that way.
Also add your workbook name to the respective area.
Sub NewWorkbooks()
'This will make seperate workbooks for each of the tabs listed
Dim wb As Workbook
Dim NewBook As Workbook
Dim ws As Worksheet
Call TurnOffFunctions
Set wb = ActiveWorkbook
For Each ws In Workbooks("YOUR WORKBOOK NAMR"). _
Worksheets(Array("frontpage", "mobile"))
ws.Copy
Set NewBook = ActiveWorkbook
With NewBook
Call break_links(NewBook)
.SaveAs Filename:="C:XXXX" & "NAME", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next
Call TurnOnFunctions
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Private Sub TurnOffFunctions()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Private Sub TurnOnFunctions()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
You can use yours too with this mod (untested):
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
Call break_links ActiveWorkbook
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
I have made the following code for moving sheet from one WB to another New WB.
However I am experiencing errors.
Sub MoveSheets01()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Application.ScreenUpdating = False
Set oldwb = ActiveWorkbook
Set newWB = Application.Workbooks.Add
oldwb.Activate
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "Output" Then
Application.DisplayAlerts = False
ws.Copy after:=newWB.Sheets(newWB.Sheets.Count)
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
oldwb.Save
newWB.Activate
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
End Sub
It generates a new WB.
But the moment I save either, the file crashes.
Try this. See comments, especially regarding the filename. Most likely you have too long filename. If error occurs - post a comment with error text.
Sub MoveSheets010()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Dim link As Variant
' switch this off for the whole sub
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set oldwb = ThisWorkbook
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "List" _
And ws.Name <> "Temp" And ws.Name <> "Index Data" _
And ws.Name <> "Ratio's" And ws.Name <> "Total Returns Index" _
And ws.Name <> "India VIX" And ws.Name <> "Output" Then
' check whether newWB is assigned
If Not newWB Is Nothing Then
' if assigned - just add sheet there
ws.Move before:=newWB.Sheets(1)
Else
' if not assign - create new workbook by moving the sheet
' this creates new workbook with only one sheet
' so there will be no "Sheet1", "Sheet2", etc
ws.Move
' assign newWB
Set newWB = ActiveWorkbook
End If
End If
Next
Set ws = Nothing
' save new wb first to avoid message about links/references
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
' remove references from source wb and save it
With oldwb
If Not IsEmpty(.LinkSources(xlExcelLinks)) Then
For Each link In .LinkSources(xlExcelLinks)
.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
.Save
End With
' switch this on back
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
My current code opens the XLS file perfectly but we now receive the files in xlsm format. I have tried to simply change the code from .xls to .XLSM but it reports that the file cannot be found.
Here is the current code:
Sub CopyRangeToAnotherSheet()
Dim wbTarget As Workbook
Dim wbThis As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbThis = ActiveWorkbook
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xls")
Sheets("Sheet1").Range("a1:m10000").Copy
Set wbTarget = ThisWorkbook
wbTarget.Sheets("Sheet1").Range("a1").PasteSpecial
Paste:=xlPasteValues
Sheets("sheet1").Activate
Application.CutCopyMode = False
wbThis.Close
Sheets("Menu Tab").Activate
End Sub
Any help appreciated!
Try catching the error and trying the new extension:
Sub CopyRangeToAnotherSheet()
Dim wbTarget As Workbook
Dim wbThis As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbThis = ActiveWorkbook
On Error Goto open_xlsm
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xls")
On Error Goto 0 ' resume normal error "handling"
Goto open_done
open_xlsm:
On Error Goto 0
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xlsm")
open_done:
Sheets("Sheet1").Range("a1:m10000").Copy
Set wbTarget = ThisWorkbook
wbTarget.Sheets("Sheet1").Range("a1").PasteSpecial
Paste:=xlPasteValues
Sheets("sheet1").Activate
Application.CutCopyMode = False
wbThis.Close
Sheets("Menu Tab").Activate
End Sub
This will check for the files foo.xsl and foo.xslm, in that order.
My code is as below. I googled a lot about 1004 error for vba in Excel 2013 and followed MS suggestion that open, save as and close here.
Anybody knows how to solve this problem?
Thanks.
Sub SaveAs(FilePath As String)
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo Whoa
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
wbTemp.SaveAs FilePath, 51
wbTemp.Close SaveChanges:=True
Set wbTemp = Nothing
Set wbTemp = Application.Workbooks.Open(FilePath)
On Error GoTo 0
For Each ws In thisWb.Sheets
If ws.Name <> "data" And ws.Name <> "parameters" Then
ws.Copy After:=wbTemp.Sheets(1)
End If
Next
wbTemp.Sheets(1).Delete
wbTemp.SaveAs FilePath, 51
LetsContinue:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
How about this:
Sub SaveAs(FilePath As String)
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo Whoa
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
wbTemp.SaveAs FilePath, 51
wbTemp.Close SaveChanges:=True
Set wbTemp = Nothing
Set wbTemp = Application.Workbooks.Open(FilePath)
On Error GoTo 0
Dim counter As Integer
counter = 0
For Each ws In thisWb.Sheets
If ws.Name <> "data" And ws.Name <> "parameters" Then
ws.Copy After:=wbTemp.Sheets(1)
counter = counter + 1
If iCounter Mod 50 = 0 Then
wbTemp.Close SaveChanges:=True
Set wbTemp = Nothing
Set wbTemp = Application.Workbooks.Open(FilePath)
End If
End If
Next
wbTemp.Sheets(1).Delete
wbTemp.SaveAs FilePath, 51
LetsContinue:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
I use an array to copy it once instead of copying sheets one by one:
Dim group As Variant, s As Integer, path As String
ReDim group(0)
For s = 1 To Sheets.Count 'or use "For Each s in ActiveWorkbook.Sheets"
If Sheets(s).Name Like "string" Then
group(UBound(group)) = Sheets(s).Name
ReDim Preserve group(UBound(group) + 1)
End If
Next s
If Application.CountA(group) > 1 Then
ReDim Preserve group(UBound(group) - 1)
Sheets(group).Copy
ActiveWorkbook.SaveAs path & "Document" & "_" & ".xlsx", FileFormat:=51
ActiveWorkbook.Close
End If