I am trying to use the code below to save Workbook files that are created from individual sheets in a secondary workbook into my department's SharePoint, but the files are not showing up after the macro has run. There are no errors showing up and when I tried running this macro in a folder on my desktop it saved all the files correctly. Any ideas as to why it just won't work when its in a SharePoint?
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
Dim theFilePath As String
MyFilePath$ = ActiveWorkbook.Path & "\"
For Each Sheet In ThisWorkbook.Worksheets
SheetName$ = Sheet.Name
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
theFilePath = MyFilePath & "FY 20-21 P Card Statements - " & SheetName
MkDir theFilePath
theFilePath = theFilePath & "/" & "February Statement 1.6.21-2.6.21"
MkDir theFilePath
With Sheet
.Select
.Copy
ActiveWorkbook.SaveAs Filename:=theFilePath & "/" & SheetName & " Feb-06.xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End With
.CutCopyMode = False
End With
Next Sheet
End Sub
Related
Good morning,
Sub pdfs()
Application.ScreenUpdating = False
Dim i As Integer
Dim nome_arquivo As String
For i = 5 To Sheets.Count
nome_arquivo = Sheets(i).Name
With Sheets(i)
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & nome_arquivo & ".xlsx"
End With
Next i
Application.ScreenUpdating = True
End Sub
How can I adapt to create Excel files (.xlsx) instead of pdf files?
I found this vba code to create excel files from sheet 5:
Sub excels()
Dim i As Integer
Dim name1 As String
For i = 5 To Sheets.Count
name1= Sheets(i).Name
Worksheets(i).Copy
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & name1 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next i
End Sub
Copy Worksheet 1 in Workbook A
Create new Workbook (named as below)
Copy worksheet 1 into new workbook
Save new workbook as 'abc (daily) & Format(Date, "ddmmmyyy") & ".xlsm" - i.e. code will save in a way that depends on today's date
I'm not sure where I'm making a mistake
'Save Worksheet1 as Workbook
Worksheets("Worksheet 1").Activate
With Worksheets("Worksheet 1")
.copy
End With
saveLocation = "X:\abc\abc\abc (daily)" & Format(Date, "ddmmmyyy") & ".xlsm"
ActiveSheet.ExportAsFixedFormat Type:=xlTypexlsm, _
Filename:=saveLocation
Sub CopySheetAsNewWorkbook()
Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
'currentWorkbook is the source workbook, create a new workbook referencing to it with theNewWorkbook
Set currentWorkbook = ActiveWorkbook
Set theNewWorkbook = Workbooks.Add
'do the copy (it's better to check if there is already a 'Worksheet 1' in the new workbook. It it exists delete it or rename it
currentWorkbook.Worksheets("Worksheet 1").Copy before:=theNewWorkbook.Sheets(1)
'Remove default sheets in order to have only the copied sheet inside the new workbook
Application.DisplayAlerts = False
Dim i As Integer
For i = theNewWorkbook.Sheets.Count To 2 Step -1
theNewWorkbook.Sheets(i).Delete
Next i
Application.DisplayAlerts = True
'Save File as XLSM
saveLocation = "X:\abc\abc\abc (daily)" & Format(Date, "ddmmmyyy") & ".xlsm"
theNewWorkbook.SaveAs Filename:=saveLocation, FileFormat:=XlFileFormat.xlOpenXMLWorkbookMacroEnabled
theNewWorkbook.Close
End Sub
Maybe try something like this:
Sub test()
Path = "D:\"
Filename = "test "
Sheets("Worksheet 1").Copy
' for multiple sheets : Sheets(Array("TABEL", "DATA", "BACKUP")).Copy
' to save with time : ActiveWorkbook.SaveAs Filename:=Path & Filename & Format(Now(), "yymmdd hh mm ss") & ".xlsm", FileFormat:=52
ActiveWorkbook.SaveAs Filename:=Path & Filename & Format(Date, "ddmmyy") & ".xlsm", FileFormat:=52
ActiveWorkbook.Close
End Sub
A Worksheet Export
Before running the code, adjust the values of variables NewFilePath
and SourceSheet in Sub exportFirst. NewFilePath must not end with a backslash \.
The code is written to refer to a worksheet in ThisWorkbook i.e. the workbook
containing this code.
Sub exportFirst is calling Sub exportWorksheet.
You can write several subs like Sub exportFirst for other
worksheets in the workbook.
I would prefer using e.g. Worksheets("Sheets1") over
Worksheets(1).
After you are done testing the code, you should probably un-comment the
line .Close.
Option Explicit
Sub exportFirst()
Const NewFilePath As String _
= "C:\Test"
Dim SourceSheet As Worksheet
Set SourceSheet = ThisWorkbook.Worksheets(1)
exportWorksheet SourceSheet, NewFilePath
End Sub
Sub exportWorksheet(SourceSheet As Worksheet, NewFilePath As String)
Dim NewFileName As String
Dim SaveLocation As String
' Either:
' ' If you want to name the new workbook using 'SourceSheet.Name':
NewFileName = SourceSheet.Name
' ' Or:
' ' If you want to name the new workbook using 'ThisWorkbook.Name':
' NewFileName _
' = Left$(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
' I would prefer "yyyymmdd" or at least "ddmmmyyyy"
SaveLocation = NewFilePath & "\" & NewFileName & " (daily)" _
& Format(Date, "ddmmmyyy")
SourceSheet.Copy
With ActiveWorkbook
' Either:
' .xlsm
SaveLocation = SaveLocation & ".xlsm"
.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
Filename:=SaveLocation
' or:
' .xlsx
' SaveLocation = SaveLocation & ".xlsx"
' .SaveAs FileFormat:=xlOpenXMLWorkbook, _
' Filename:=SaveLocation
' or:
' .csv
' SaveLocation = SaveLocation & ".csv"
' .SaveAs FileFormat:=xlCSVUTF8, Filename:=SaveLocation
' or:
' .pdf
' SaveLocation = SaveLocation & ".pdf"
' .ExportAsFixedFormat Type:=xlTypePDF, Filename:=SaveLocation
' .Saved = True
'.Close ' You should use '.Close' always with '.pdf'.
End With
End Sub
Mac Excel v16.16.7 - Trying to use a macro to export the active sheet of an xlsm file to a csv with the sheet name as the file name.
I'm aware of the sandboxing issues and thought I was getting around them with GrantAccessToMultipleFiles, but the exact macro below delivers three different outcomes:
Sometimes it works. Saves the sheet as a CSV in the same directory as the workbook.
400 error
Run-time error '1004' Application-defined or object-defined error
Sub SaveAsCSV()
Dim strName As String
Dim fileAccessGranted As Boolean
Dim filePermissionCandidates
filePermissionCandidates = Array(ThisWorkbook.Path & Application.PathSeparator & ActiveSheet.Name & ".csv")
fileAccessGranted = GrantAccessToMultipleFiles(filePermissionCandidates)
If fileAccessGranted = True Then
Application.ScreenUpdating = False
strName = ThisWorkbook.Path & Application.PathSeparator & ActiveSheet.Name & ".csv"
ActiveSheet.Copy 'copy the sheet as a new workbook
ActiveWorkbook.SaveAs Filename:=strName, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "File has been Created and Saved as: " & vbCr & strName, , "Copy & Save Report"
End If
End Sub
I'm hoping for some insight into why the outcomes are varied. Thanks!
I'm searching for a code to run the same macro on 200+ files in the same folder directory until the last file is complete.
The macro I have currently does this once I click a button
Refresh .CSV data connection (File Selection window pops up in
the directory, I select the file)
Refreshes Pivot Table
Deletes Specific Tabs
Saves Copy As in another Directory
I want to eliminate me clicking the RUN button 200+ times, and selecting the .CSV file. Would anyone happen to know of a code that could do this?
Current MACRO is:
Sub Load_Brand3()
' Load_Brand3 Macro
Sheets("Data").Select
Range("DATATable[[#Headers],[Datetime]]").Select
Selection.ListObject.TableObject.Refresh
Sheets("Brand Summary").Select
Range("A13").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
ActiveSheet.PivotTables("PivotTable1").PivotFields("Retailer.Name").ShowDetail _
= False
Sheets("Brand Summary").Select
Dim SavedCopy As Excel.Workbook
ActiveWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Workbooks.Open "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = ActiveWorkbook
With SavedCopy
ActiveWorkbook.Connections("BrandExport").Delete
Application.DisplayAlerts = False
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Sheets("Brand Summary").Select
Range("A1").Select
Application.DisplayAlerts = True
.Close True
End With
MsgBox ("Your File was saved.")
End Sub
This should be close. Just change MyPath to the correct directory and run ProcessFiles.
Sub ProcessFiles()
Const MyPath As String = "C:\Users\best buy\Data Files\*.csv"
Dim FileName As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
FileName = Dir(MyPath, vbDirectory)
Do While FileName <> ""
Load_BrandFile FileName
FileName = Dir()
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sub Load_BrandFile(FileName As String)
Dim SavedCopy As Workbook
Dim DATATable As ListObject
Dim PivotTable1 As PivotTable
ThisWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = Workbooks.Open("C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm")
With SavedCopy
Set DATATable = .Worksheets("Data").ListObjects("DATATable")
DATATable.Refresh
Set PivotTable1 = .Worksheets("Brand Summary").PivotTables("PivotTable1")
PivotTable1.PivotCache.Connection = FileName
PivotTable1.PivotFields("Retailer.Name").ShowDetail = False
.Connections("BrandExport").Delete
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Application.Goto Reference:=.Worksheets("Brand Summary").Range("A1"), scroll:=True
.Close True
End With
End Sub
Hopefully this sorts it for you.
Sub CycleFolder()
Dim folderSelect As FileDialog
Set folderSelect = Application.FileDialog(msoFileDialogFolderPicker)
With folderSelect
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
strItem = .SelectedItems(1)
End With
Files = Dir(strItem & "\")
While Files <> ""
'RUN FUNCTION HERE
'Uncomment next line to test iteration
'Debug.Print Files
Files = Dir
Wend
End Sub
I have an Excel macro that is copying all of the information from a specific worksheet and copying it into a new workbook. The code is as follows:
Option Explicit
Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "New Copy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
On Error GoTo ErrCatcher
Sheets("Input").Copy
On Error GoTo 0
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
NewName = InputBox("Please specify the name of your new workbook", "New Copy", "input")
Dim sPath As String
sPath = ThisWorkbook.Path
ActiveWorkbook.SaveCopyAs sPath & NewName + ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
However, it does not save the new Excel file in the correct directory. The original Excel file, the one that contains the macro, is in the following directory (on a Mac):
/Applications/WORDNET/PROJECTS
However, every time I run the macro, it saves the new Excel file in the WORDNET folder, instead of the PROJECTS folder.
How do I modify the code so that it saves in the correct place? And why does it not save in the same directory as the original Excel file?
sPath = ThisWorkbook.Path
sPath is the path without a seperator at the end (at least on Windows) so you have to add one in your script. In your case, the files will be saved to /Applications/WORDNET with the name "PROJECTS" & NewName
Unix:
ActiveWorkbook.SaveCopyAs sPath & "/" & NewName + ".xls"
Windows:
ActiveWorkbook.SaveCopyAs sPath & "\" & NewName + ".xls"