I'm trying to write a simple macro to run on my Mac (Excel 16.61, Mac Book Pro running Big Sur 11.4) that copies the visible rows of a table into a new workbook then saves the new workbook as a *.csv file.
The current (non-working) code:
Sub Macro()
Dim wb as Workbook
Dim wbOutput As Workbook
Dim FilePath As String
Set wb = ThisWorkbook
FilePath = "/path/to/filename.csv"
' Copy the visible rows of a filtered table
With wb.Sheets("WorksheetName").ListObjects("tblName")
.Range.AutoFilter Field:=18, Criteria1:="TRUE"
.Range.SpecialCells(xlCellTypeVisible).Copy
End With
' Paste the copied table rows into a new workbook and save as a *.csv file
Set wbOutput = Workbooks.Add
wbOutput.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
wbOutput.SaveAs FileName:=FilePath, FileFormat:=xlCSV, CreateBackup:=False
wbOutput.Close
End Sub
When I run it however I get the following error:
Run-time error '1004': Cannot access read-only document [filename]
Having spent a few hours searching on-line, I'm no closer to a solution. The internet's suggestions include:
Adding Excel in System Preferences.../Security & Privacy/Files and Folders (I can't see an obvious way of adding a new app, just remove the access rights of apps that already have folder access)
The GrantAccessToMultipleFiles function, but adding FilePath in the input array of the function makes no difference.
How can I create a *.csv file from the table?
Ran into the same issue but my file format was .txt but here was my solution after doing some research and getting some solid help from the Mac VBA Guru Ron De Bruin.
The code essentially bypass creating the output files, in my case .txt files in a folder location that has security protocols that cause the Error 1004 message and creates a subfolder in the Microsoft Folder under my User profile which for whatever reason Excel/Mac don't see as a security threat and allows the VBA to create/save the output file(s) into that folder.
Hopefully, you can extract out what you need from the code and Function to get yours to work. One other thing, since the output is going to such a weird folder location I suggest you save the folder path under your favorites on the Finder Left Panel so you can easily get to the files. See the MsgPopup box for the folder location
Sub Create_TxtFiles()
Dim MacroFolder As String
Dim nW As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim DT As String, RelativePath As String, wbNam1 As String, wbNam2 As String, Filepath As String
'Declarations
Set ws1 = ThisWorkbook.Sheets("Extract1")
Set ws2 = ThisWorkbook.Sheets("Extract2")
RelativePath = ThisWorkbook.Path & "/"
DT = Format(CStr(Now), "mm_dd_yyyy hh.mmam/pm")
wbNam1 = "Extract 1 Output" 'Creates the File Name
wbNam2 = "Extract 2 Output" 'Creates the File Name
MacroFolder = "Upload Files"
Call CreateFolderinMacOffice2016(MacroFolder)
'set the savepath as the obscure folder vba has access to'
savepath = Application.DefaultFilePath & MacroFolder & "/"
'copy the Output 1
ws1.Copy
ActiveWorkbook.SaveAs savepath & wbNam1 & DT & ".txt", FileFormat:=42
Workbooks(wbNam1 & DT & ".txt").Close
'copy the Output 2
ws2.Copy
ActiveWorkbook.SaveAs savepath & wbNam2 & DT & ".txt", FileFormat:=42
Workbooks(wbNam2 & DT & ".txt").Close
Application.ScreenUpdating = True
msgbox ("Upload file saved to folder: " & vbNewLine & vbNewLine & savepath)
End Sub
Function CreateFolderinMacOffice2016(NameFolder As String) As String
'Function to create folder if it not exists in the Microsoft Office Folder
'Ron de Bruin : 1-Feb-2019
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = Application.DefaultFilePath
PathToFolder = OfficeFolder & NameFolder
On Error Resume Next
TestStr = Dir(PathToFolder & "*", vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
End If
CreateFolderinMacOffice2016 = PathToFolder
End Function
Related
New to VBA and have an assignment to create a sub that pastes from one workbook into a new workbook. A requirement for saving the file is that "the folder path be universal so other people can create this folder too". What amendment would I make to the ActiveWorkbook.SaveAs method to fulfill this? Thanks
Sub pasteTable()
Dim formatting As Variant 'create variable to hold formatting2 workbook path
formatting = Application.GetOpenFilename() 'user is prompted and selects path to formatting2 workbook and assigns to formatting variable
Workbooks.Open formatting 'formatting2 workbook is now active
Worksheets("Formatting").Range("B3:R13").Copy 'copies table from formatting2 workbook
Workbooks.Add 'add new workbook
Worksheets(1).Range("B3:R13").Select 'selects range on worksheet of new workbook to paste table
Selection.PasteSpecial xlPasteAll 'pastes table
Columns("B:R").ColumnWidth = 20 'ensures table has proper row and column heights/widths
Rows("3:13").RowHeight = 25
Worksheets(1).Name = "Table Data" 'renames worksheet
ActiveWorkbook.SaveAs "C:\Users\name\Desktop\names Excel Assessment VBA\names Excel Assessment VBA " & Format(Date, "dd/mmm/yyyy"), FileFormat:=xlOpenXMLWorkbookMacroEnabled
'saves workbook according to desired specifications
End Sub
Change your Save line to this:
ActiveWorkbook.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\Excel Assessment VBA\Excel Assessment VBA " & Format(Date, "dd-mmm-yyyy") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
The Username system variable will adjust depending on the Windows account that is in use. Just make sure each user has those folders existing on their desktop too, or you will get an error. I also removed names from the folder names as i assume you were trying to do something with the username there as well. You can adjust that to your needs.
Your Date format needed to change too as it was including illegal characters.
You also forgot to include a file extension, so I added that as well.
There is a lot going on with that line, including a lot of mistakes, so you are going to have to play with it a bit until you get exactly what you need. You may want to simplify it a bit until you get the hang of all those things.
I think you have to add some more checks
The script expects the name of the tool-path-folder as constant ToolFolder.
Plus a second constant ToolBaseFolder that could be set to the parent-path `ToolFolder, e.g. a network path. If the const is empty, users desktop will be used.
If this path does not yet exist it will be created.
Option Explicit
Private Const ToolBaseFolder As String = "" 'if ToolBaseFolder is an empty string desktop will be used instead
Private Const ToolFolder As String = "MyNameForToolFolder"
Public Sub testWbToToolFolder()
'this is just for testing
Dim wb As Workbook: Set wb = ActiveWorkbook
saveWbToToolFolder wb, "test.xlsx"
End Sub
Public Sub saveWbToToolFolder(wb As Workbook, filename As String)
'you don't need this sub - but have the same code line in your main routine
wb.SaveAs getToolFolder & filename
End Sub
Public Function getToolFolder() As String
'this returns the toolfolder e.g. C:\Users\xyz\Desktop\MyNameForToolFolder
Dim basepath As String
basepath = ToolBaseFolder & "\"
If existsFolder(basepath) = False Then
If LenB(ToolBaseFolder) > 0 Then
MsgBox ToolBaseFolder & " does not exist." & vbCrLf & _
"File will be saved to " & ToolFolder & " on desktop ", vbExclamation
End If
basepath = getDesktopFolderOfUser
End If
Dim fullpath As String
fullpath = basepath & ToolFolder & "\"
If existsFolder(fullpath) = False Then
makeFolder fullpath
End If
getToolFolder = fullpath
End Function
Private Function existsFolder(path As String) As Boolean
If Len(path) < 2 Then Exit Function 'can't be a valid folder
existsFolder = LenB(Dir(path, vbDirectory)) > 0
End Function
Private Function getDesktopFolderOfUser() As String
getDesktopFolderOfUser = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
End Function
Private Function makeFolder(path As String)
'https://stackoverflow.com/a/26934834/16578424 plus comment from rayzinnz
CreateObject("WScript.Shell").Run "cmd /c mkdir """ & path & """", 0, True
End Function
I have multiple workbooks in a folder #1 and I'm trying to copy certain cells information from one worbook to another.
The source files in the folder are .xslm and named "1" "2" "3".... etc
The target files (which I'm trying to copy the cells to) are in another folder are .csv and named "1" "2" "3".... etc
I have about 1000 files that I'm trying information from. so copying them one by one will take me forever
Source File Screenshot
Target File Screenshot
Assuming the files you want to copy from are in a folder C:\MyExcelFiles\ and assuming they are named 1.xlsm, 2.xlsm and the output files should be 1.xls and 2.xls, then it is a straight forward thing to do:
Sub CopyMacro()
Dim SourceFolder As String
Dim SourceFileName As String
Dim DestinationFileName As String
Dim SourceWorkbook As String
Dim DestinationWorkbook As String
SourceFolder = "C:\MyExcelFiles\"
Application.DisplayAlerts = False ' avoid security warning
For I = 1 To 100
SourceFileName = SourceFolder & I & ".xlsm"
DestinationFileName = SourceFolder & I & ".xls" ' could be any other file
On Error Resume Next
Workbooks.Open SourceFileName, ReadOnly:=True
If Err > 0 Then
MsgBox "Could not open file :" & SourceFileName
Exit Sub
End If
SourceWorkbook = ActiveWorkbook.Name
On Error GoTo 0
ActiveWorkbook.Sheets(1).Activate ' assuming the data you want to copy is on the first sheet
Range("a1:d6").Copy
Workbooks.Add
DestinationWorkbook = ActiveWorkbook.Name
Range("a1").PasteSpecial xlPasteValues
Workbooks(DestinationWorkbook).SaveAs DestinationFileName
ActiveWorkbook.Close
Workbooks(SourceWorkbook).Close
DoEvents ' give a chance for mouse events and keyboard events to get executed
' this will also allow you to press CTRL+PAUSE if you want to stop the macro
Next
Application.DisplayAlerts = True 'Switch alerts back on
End Sub
Please keep in mind, I did not test the code. But I am sure you will be able to fix it if it has any bugs, or errors.
I'm trying to share an Excel workbook, but with limited access to only a couple of visible sheets. This have proven to be much harder than first anticipated due to security loopholes with Excel and password protection of worksheets.
My problem arises due to some hidden sheets that needs to stay hidden and the contents inaccessible, but are required for calculations were the result is shown in the visible sheets.
So far I have tried to "super hide" the sheets in the VBA window and lock the VBA project. The idea is that the user then can't unhide the "super hidden" sheets without the VBA project password.
I have tried to add additional VBA code to counter certain "attacks", but I keep coming back to a known flaw that circumvents all my efforts:
Step 1:
Save or make sure that the Excel workbook is saved as .xlsx or .xlsm
Step 2:
Run the following code from a different workbook or your personal.xlsb that removes passwords from sheets and structure protection
(I would have linked to the post where I found the code, but I can't find it right now...).
Sub RemoveProtection()
Dim dialogBox As FileDialog
Dim sourceFullName As String
Dim sourceFilePath As String
Dim SourceFileName As String
Dim sourceFileType As String
Dim newFileName As Variant
Dim tempFileName As String
Dim zipFilePath As Variant
Dim oApp As Object
Dim FSO As Object
Dim xmlSheetFile As String
Dim xmlFile As Integer
Dim xmlFileContent As String
Dim xmlStartProtectionCode As Double
Dim xmlEndProtectionCode As Double
Dim xmlProtectionString As String
'Open dialog box to select a file
Set dialogBox = Application.FileDialog(msoFileDialogFilePicker)
dialogBox.AllowMultiSelect = False
dialogBox.Title = "Select file to remove protection from"
If dialogBox.show = -1 Then
sourceFullName = dialogBox.SelectedItems(1)
Else
Exit Sub
End If
'Get folder path, file type and file name from the sourceFullName
sourceFilePath = Left(sourceFullName, InStrRev(sourceFullName, "\"))
sourceFileType = Mid(sourceFullName, InStrRev(sourceFullName, ".") + 1)
SourceFileName = Mid(sourceFullName, Len(sourceFilePath) + 1)
SourceFileName = Left(SourceFileName, InStrRev(SourceFileName, ".") - 1)
'Use the date and time to create a unique file name
tempFileName = "Temp" & Format(Now, " dd-mmm-yy h-mm-ss")
'Copy and rename original file to a zip file with a unique name
newFileName = sourceFilePath & tempFileName & ".zip"
On Error Resume Next
FileCopy sourceFullName, newFileName
If Err.Number <> 0 Then
MsgBox "Unable to copy " & sourceFullName & vbNewLine _
& "Check the file is closed and try again"
Exit Sub
End If
On Error GoTo 0
'Create folder to unzip to
zipFilePath = sourceFilePath & tempFileName & "\"
MkDir zipFilePath
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(zipFilePath).CopyHere oApp.Namespace(newFileName).Items
'loop through each file in the \xl\worksheets folder of the unzipped file
xmlSheetFile = Dir(zipFilePath & "\xl\worksheets\*.xml*")
Do While xmlSheetFile <> ""
'Read text of the file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<sheetProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 '"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\worksheets\" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Loop to next xmlFile in directory
xmlSheetFile = Dir
Loop
'Read text of the xl\workbook.xml file to a variable
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" For Input As xmlFile
xmlFileContent = Input(LOF(xmlFile), xmlFile)
Close xmlFile
'Manipulate the text in the file to remove the workbook protection
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<workbookProtection")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, _
xmlFileContent, "/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Manipulate the text in the file to remove the modify password
xmlStartProtectionCode = 0
xmlStartProtectionCode = InStr(1, xmlFileContent, "<fileSharing")
If xmlStartProtectionCode > 0 Then
xmlEndProtectionCode = InStr(xmlStartProtectionCode, xmlFileContent, _
"/>") + 2 ''"/>" is 2 characters long
xmlProtectionString = Mid(xmlFileContent, xmlStartProtectionCode, _
xmlEndProtectionCode - xmlStartProtectionCode)
xmlFileContent = Replace(xmlFileContent, xmlProtectionString, "")
End If
'Output the text of the variable to the file
xmlFile = FreeFile
Open zipFilePath & "xl\workbook.xml" & xmlSheetFile For Output As xmlFile
Print #xmlFile, xmlFileContent
Close xmlFile
'Create empty Zip File
Open sourceFilePath & tempFileName & ".zip" For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'Move files into the zip file
oApp.Namespace(sourceFilePath & tempFileName & ".zip").CopyHere _
oApp.Namespace(zipFilePath).Items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(sourceFilePath & tempFileName & ".zip").Items.count = _
oApp.Namespace(zipFilePath).Items.count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the files & folders created during the sub
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder sourceFilePath & tempFileName
'Rename the final file back to an xlsx file
Name sourceFilePath & tempFileName & ".zip" As sourceFilePath & SourceFileName _
& "_" & Format(Now, "dd-mmm-yy h-mm-ss") & "." & sourceFileType
'Show message box
MsgBox "The workbook and worksheet protection passwords have been removed.", _
vbInformation + vbOKOnly, Title:="Password protection"
End Sub
Step 3:
Run the following code to unhide all sheets
Sub UnhideAllSheets()
For Each Worksheet In ActiveWorkbook.Sheets
Worksheet.Visible = -1
Next Worksheet
End Sub
The workbook is now clean of passwords on sheets and structure protection, and any "counter" VBA code is gone by saving the workbook as a .xlsx file.
I have thought about adding a user-defined function that checks if the extension of the workbook file is ".xlsb". The function would return "1" if the extension is ".xlsb" and then multiplying it on something important. This would cause the calculations to fail if the workbook is saved as something else, or if the VBA project is entirely removed to saving as .xlsx.
However, I do not like this approach as I don't think it is a long-term solution...
My question is therefore:
Is there a way to securely share an Excel workbook with only access to a couple of sheets without risking the user can access hidden sheets and/or unwanted contents?
In the VBE you can change the Visible property of a specific sheet to xlSheetVeryHidden.
This will remove it from the front end completely.
You can then add a password to protect the VBA project in the VBE to prevent a user from changing that property (if they even know about it).
Additionally, you will still be able to access these sheets with your VBA code.
EDIT:
What I also add to the above is a password to the specific sheet, as normal. But also a custom UserForm the UserForm gets triggered on the Worksheet_Activate event if they had to unhide it. If they enter the incorrect password or close the UserForm the sheet gets hidden away again. You can add all sorts to this event handler such as reprotect the worksheet, reprotect the project, protect the workbook with an encrypted password and close the workbook as a "breach" in security.
The possibilities are endless. Not an exact prevention, but hopefully this helps.
I have a code in excel VBA that saves a workbook with a coded path and filename which works perfectly on my computer at home running windows 8 and office 2013.
When I try to use it on my work computer which runs windows XP and office 2003 it ignores the coded path and file name and opens the save as dialogue box which defaults to the My Documents directory.
The intent is for the users at work to click save and the file will automatically go to a network drive with a personalised filename. They should not have to select a path or filename.
I have been testing with the path C:\Temp\ and saving a plain .XLS file which should work on both versions of Excel.
I tried it without disabling alerts and it gave no clues as to why it ignores the path and filename. I have also tried fileformat:=xlnormal etc. with no luck.
Why is this happening and how do I fix it?
Here is the code:
Sub FeedBackSave()
' Save the Feedback worksheet created by the user to the network drive using the path copied from
' the Management workhseet cell A11, the resource name copied from cell A1 and todays date as the filename.
Dim wsh As Worksheet
Dim nme, pth, TodaysDate As String
TodaysDate = format(Now, "dd-mm-yy")
nme = Range("A1").Value
pth = Worksheets("Management").Range("A11").Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False ' Prevents alerts like incorrect file type or overwrite file y/n to permit 1 click save
'Save Feedback worksheet
ActiveWorkbook.Close SaveChanges:=True, Filename:=pth & "FeedBack " & nme & " " & TodaysDate & ".xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Saveas Before you close the workbook, might help., check the ranges, not sure if they are on the same sheet or not.
Sub FeedBackSave()
' Save the Feedback worksheet created by the user to the network drive using the path copied from
' the Management workhseet cell A11, the resource name copied from cell A1 and todays date as the filename.
Dim wsh As Worksheet
Dim nme As String, pth As String, TodaysDate As String, FName As String
Set ws = Worksheets("Management")
TodaysDate = Format(Now, "dd-mm-yy")
nme = Range("A1").Value
pth = ws.Range("A11").Value
FName = pth & nme & "-" & TodaysDate & ".xls"
Application.DisplayAlerts = 0
With ActiveWorkbook
.SaveAs FileName:=FName
.Close
End With
End Sub
The answers to How can I install/use “Scripting.FileSystemObject” in Excel 2011 for MAC? seem to indicate that using Scripting.FileSystemObject in Excel 2010 for the mac is not possible.
What other alternative is available so I can:
get a collection of all Excel files in a specific directory
iterate through each worksheet within each file and export it to a .csv file
Currently this is a six-step process for each file:
--how to create CSV files for all worksheets in a file:
1. open file
2. click "Developer"
3. click editor
4. click ThisWorkbook
5. copy in:
Sub save_all_csv()
On Error Resume Next
Dim ExcelFileName As String
ExcelFileName = ThisWorkbook.Name
For Each objWorksheet In ThisWorkbook.Worksheets
Filename = "FILE-" & ExcelFileName & "-WORKSHEET-" & objWorksheet.Name & ".csv"
objWorksheet.SaveAs Filename:="Macintosh HD:Users:edward:Documents:temporaryNoBackup:" & Filename, FileFormat:=xlCSV, CreateBackup:=False
Next
Application.DisplayAlerts = False
Application.Quit
End Sub
6. click run (it closes by itself)
I'm looking for a way to automate this on the Mac, ideally, a (cron job?, service?) would open the excel file every 10 minutes, which would in turn look in a directory, convert all the other Excel files to .csv files, and then close by itself.
Without Scripting.FileSystemObject, how can I make this Excel-to-CSV conversion fully automatic on the Mac?
The only way I can think of is using the "Dir" function. Since mac supports extra characters in their filenames, wildcards do not work with the "Dir" function. Here is a sample.
Function GetFileList(folderPath As String) As Collection
'mac vba does not support wildcards in DIR function
Dim file As String
Dim returnCollection As New Collection
If Right$(folderPath, 1) <> "/" Then
folderPath = folderPath & "/"
End If
file = Dir$(folderPath) 'setup initial file
Do While Len(file)
returnCollection.Add folderPath & file
file = Dir$
Loop
Set GetFileList = returnCollection
End Function
You can put the VBA in an add-in (.xlam file) that is attached to Excel itself, rather than the workbook. For your example code, the only modification would be to write against ActiveWorkbook instead of ThisWorkbook.
Sub save_all_csv()
On Error Resume Next
Dim ExcelFileName As String
ExcelFileName = ActiveWorkbook.Name
For Each objWorksheet In ActiveWorkbook.Worksheets
Filename = "FILE-" & ExcelFileName & "-WORKSHEET-" & objWorksheet.Name & ".csv"
objWorksheet.SaveAs Filename:="Macintosh HD:Users:edward:Documents:temporaryNoBackup:" & Filename, FileFormat:=xlCSV, CreateBackup:=False
Next
Application.DisplayAlerts = False
Application.Quit
End Sub
You can also leverage auto_open() to automate binding a hotkey. Once that's done, you can just open a workbook, press a hotkey, and get your CSV files.
Public Sub auto_open()
' Register hotkeys
' See key codes here
' https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-onkey-method-excel
' ^ = CTRL
' % = ALT
' + = SHIFT
Application.OnKey "^+e", "save_all_csv" ' Ctrl+Shift+E will call save_all_csv()
End Sub