I have been doing checks with worksbooks for things like if the sheet exists or what is in a cell without opening the workbook using this command
f = "'" & strFilePath1 & "[" & strFileType & "]" & strSheetName & "'!" & Range(strCell).Address(True, True, -4150)
CheckCell = Application.ExecuteExcel4Macro(f)
and it has been working well but now i am wanting to check if the sheet is Password protected without opening but haven't been successful. Anyone know if this is possible?
Thanks for help in advance
Yes! It is possible. I discovered how to do it long time ago. I doubt this is mentioned anywhere in the web...
Basic Introduction: As you are aware, Microsoft Excel up until 2007 version used a proprietary binary file format called Excel Binary File Format (.XLS) as its primary format. Excel 2007 onwards uses Office Open XML as its primary file format, an XML-based format that followed after a previous XML-based format called "XML Spreadsheet" ("XMLSS"), first introduced in Excel 2002.
Logic: To understand how this works, do the following
Create a new Excel file
Ensure it has at least 3 sheets
Protect the 1st sheet with a blank password
Leave the 2nd sheet unprotected
Protect the 3rd sheet using any password
Save the file, say, as Book1.xlsx and close the file
Rename the file to, say, Book1.Zip
Extract the contents of the zip
Go to the folder \xl\worksheets
You will see that all the sheets from the workbook has been saved as Sheet1.xml,Sheet2.xml and Sheet3.xml
Right click on the sheets and open it in notepad/notepad++
You will notice that all the sheets you protected has one word <sheetProtection as shown below
So if we can somehow check if the relevant sheet has that word then we can ascertain whether the sheet is protected or not.
Code:
Here is a function which can help you in what you want to achieve
'~~> API to get the user temp path
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Sub Sample()
'~~> Change as applicable
MsgBox IsSheetProtected("Sheet2", "C:\Users\routs\Desktop\Book1.xlsx")
End Sub
Private Function IsSheetProtected(sheetToCheck As Variant, FileTocheck As Variant) As Boolean
'~~> Temp Zip file name
Dim tmpFile As Variant
tmpFile = TempPath & "DeleteMeLater.zip"
'~~> Copy the excel file to temp directory and rename it to .zip
FileCopy FileTocheck, tmpFile
'~~> Create a temp directory
Dim tmpFolder As Variant
tmpFolder = TempPath & "DeleteMeLater"
'~~> Folder inside temp directory which needs to be checked
Dim SheetsFolder As String
SheetsFolder = tmpFolder & "\xl\worksheets\"
'~~> Create the temp folder
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(tmpFolder) = False Then
MkDir tmpFolder
End If
'~~> Extract zip file in that temp folder
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tmpFolder).CopyHere oApp.Namespace(tmpFile).items
'~~> Loop through that folder to work with the relevant sheet (file)
Dim StrFile As String
StrFile = Dir(SheetsFolder & sheetToCheck & ".xml")
Dim MyData As String, strData() As String
Dim i As Long
Do While Len(StrFile) > 0
'~~> Read the xml file in 1 go
Open SheetsFolder & StrFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
For i = LBound(strData) To UBound(strData)
'~~> Check if the file has the text "<sheetProtection"
If InStr(1, strData(i), "<sheetProtection", vbTextCompare) Then
IsSheetProtected = True
Exit For
End If
Next i
StrFile = Dir
Loop
'~~> Delete temp file
On Error Resume Next
Kill tmpFile
On Error GoTo 0
'~~> Delete temp folder.
FSO.deletefolder tmpFolder
End Function
'~~> Get User temp directory
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
Note: This has been tested for .xlsx and .xlsm files.
Related
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
I have an Excel file (https://www.dropbox.com/s/hv9u68s136es190/Example2.xlsx?dl=0) with in column A all the persons and in the cell next to there name text (column B).
I want to save for every person a text file containing the text in the cell next to there name.
The filename should be called like the persons name.
So in this case i would have three text files. I do not know how to manage this using VBA in Excel.
Can someone help me with this?
Try this code, please. But, you must initially try something on your own. We usually help people correct their code and learn...
The text files will be named like the people names in column A. The folder where they will be saved will be the one of the workbook which keeps the active sheet. You can define it as you need, of course.
Option Explicit
Sub SaveTxtNamePlusTekst()
Dim sh As Worksheet, lastR As Long, i As Long, strPath As String
Set sh = ActiveSheet ' use here the sheet you need
strPath = sh.Parent.path 'you can define here the path you wish...
If Dir(strpath, vbDirectory) = "" Then MsgBox "The folder path is not valid...": Exit Sub
lastR = sh.Range("A" & Cells.Rows.Count).End(xlUp).row 'Last row in A:A
For i = 2 To lastR
'calling a Sub able to create a text file in a folder and put text in it
WriteText sh.Range("A" & i).value, strPath, sh.Range("B" & i).value
Next i
End Sub
Private Sub WriteText(strName As String, strPath As String, strText As String)
Dim filePath As String
filePath = strPath & "\" & strName & ".txt" 'building the txt file path
FreeFile 1
Open filePath For Output As #1
Print #1, strText 'write the text
Close #1
End Sub
I have a macro that compiles rows within tables across multiple files. All files are essentially copies of the "master" file. Each file is used by a different person.
The rows to copy are on "Table_Data" in "Tracker" sheet, with these names being stored in constant variables.
The macro first checks if the pre-defined list of individual files exist in the same folder and are not open.
Once that check is passed, the files are opened one by one, with all data in the table read into an array.
That array is looped through to copy rows, that fit certain requirements, into a compiled array.
Once that is done, the array is emptied, file #1 is closed and file #2 is opened to repeat the above step.
Once all required rows have been copied into the compiled array, the array is pasted in the master file.
As part of error checking, I want to check if the pre-defined list of files have the correct sheetname and the correct table name inside that sheet, BEFORE opening the file. If one of the files is not valid, I don't want the compiler to start.
I found snippets of code, but I haven't been able to make any of them give me a True/False on whether or not the sheet and table exist on the file while the file is closed.
Checking If A Sheet Exists In An External Closed Workbook
Excel VBA - Get name of table based on cell address
I have this, however, the file has to be opened, which slows down the macro.
To save time, I call it before copying the rows from each file and if the file is not valid, do not compile and show message stating which files are not valid.
Option Explicit
Function IsFileValid(ByVal strFileName As String) As Boolean
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & strFileName, True, True)
On Error Resume Next
If Worksheets(wrkshtTracker).ListObjects(tableTracker).Range(1, 2) = strEmailHeader Then
IsFileValid = True
End If
wb.Close False
Set wb = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
End Function
I want this check before opening the files.
Let's say our excel file looks like this
Logic:
Copy the excel file to user temp directory and rename it to say "Test.Zip"
Unzip the Zip files
We will keep our attention to 2 different folders. \xl\worksheets and \xl\tables. This is where the xml files are created.
\xl\worksheets If a sheet exists then an xml will be created with that name as shown below.
\xl\tables If a table exists then an xml will be created as shown below. However in this case, it is not necessary that the name of the table will be the same as the file name. However the name of the table will be inside the xml file as shown below
and this is the content of the 2nd xml file.
So simply check if the xml file exists for the sheet and for the table, check the contents of the file.
Code:
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Dim zipFilePath As Variant
Dim tmpDir As Variant
Dim filePath As String
Dim oApp As Object
Dim StrFile As String
Sub Sample()
filePath = "C:\Users\routs\Desktop\sid.xlsx"
tmpDir = TempPath & Format(Now, "ddmmyyhhmmss")
zipFilePath = tmpDir & "\Test.Zip"
MsgBox DoesSheetExist("Sheet1")
MsgBox DoesTableExist("Table13")
End Sub
'~~> Function to check if a sheet exists
Private Function DoesSheetExist(wsName As String) As Boolean
MkDir tmpDir
FileCopy filePath, zipFilePath
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tmpDir & "\").CopyHere oApp.Namespace(zipFilePath).items
If Dir(tmpDir & "\xl\worksheets", vbDirectory) <> "" Then
StrFile = Dir(tmpDir & "\xl\worksheets\*.xml")
Do While Len(StrFile) > 0
If UCase(Left(StrFile, (InStrRev(StrFile, ".", -1, vbTextCompare) - 1))) = UCase(wsName) Then
DoesSheetExist = True
Exit Do
End If
StrFile = Dir
Loop
End If
If Len(Dir(tmpDir, vbDirectory)) <> 0 Then
CreateObject("Scripting.FileSystemObject").DeleteFolder tmpDir
End If
End Function
'~~> Function to check if a table exists
Private Function DoesTableExist(tblName As String) As Boolean
Dim MyData As String, strData() As String
Dim stringToSearch As String
stringToSearch = "name=" & Chr(34) & tblName & Chr(34)
MkDir tmpDir
FileCopy filePath, zipFilePath
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tmpDir & "\").CopyHere oApp.Namespace(zipFilePath).items
If Dir(tmpDir & "\xl\tables", vbDirectory) <> "" Then
StrFile = Dir(tmpDir & "\xl\tables\*.xml")
Do While Len(StrFile) > 0
Open tmpDir & "\xl\tables\" & StrFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
If InStr(1, MyData, stringToSearch, vbTextCompare) Then
DoesTableExist = True
Exit Do
End If
StrFile = Dir
Loop
End If
If Len(Dir(tmpDir, vbDirectory)) <> 0 Then
CreateObject("Scripting.FileSystemObject").DeleteFolder tmpDir
End If
End Function
'~~> Function to get user temp directory
Private Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
Suppose, we have one folder with only one macro file and every day we are saving excel file in the same folder received via mail. However, filename every day will get changed. I mean to say what ever file we are getting through mail do not have a standard name. Now, we have two files in the same folder.
Can we open another file which we have saved with some random name available in the same folder using a macro? Here, the name of another file is not standard. Additionally, after running a macro, we also want to delete that file.
You can get the filename of the newest file within a directory by this:
Option Explicit
Private Sub GetNewestFilename()
Dim searchDirectory As String
Dim searchPattern As String
Dim currentFilename As String
Dim NewestFilename As String
Dim NewestFiledate As Date
searchDirectory = Application.DefaultFilePath & "\"
searchPattern = "*.xl*"
currentFilename = Dir(searchDirectory & searchPattern, 0)
If currentFilename <> "" Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
Do While currentFilename <> ""
If FileDateTime(searchDirectory & currentFilename) > NewestFiledate Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
End If
currentFilename = Dir
Loop
End If
MsgBox NewestFilename
Dim wb As Workbook
Set wb = Workbooks.Open(searchDirectory & NewestFilename)
' do something
wb.Close SaveChanges:=False
Set wb = Nothing
' Kill searchDirectory & NewestFilename ' Delete the file
End Sub
I have written below code to generate data into notepad format from MS excel using VB code.
I am getting the file in notepad but problem is that if there are multiple sheet in the excel then also I am getting a single extract. I want to get the extract of all the sheet in a diff file.
please suggest.
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
'~~> Change this where and how you want to save the file
Const FlName = "C:\My\excel\MyWorkbook.vbs"
Sub Sample()
Dim tmpFile As String
Dim MyData As String, strData() As String
Dim entireline As String
Dim filesize As Integer
'~~> Create a Temp File
tmpFile = "C:\My\excel\Sheet1.vbs"
ActiveWorkbook.SaveAs Filename:=tmpFile _
, FileFormat:=xlText, CreateBackup:=False
'~~> Read the entire file in 1 Go!
Open tmpFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Get a free file handle
filesize = FreeFile()
'~~> Open your file
Open FlName For Output As #filesize
For i = LBound(strData) To UBound(strData)
entireline = Replace(strData(i), """", "")
'~~> Export Text
Print #filesize, entireline
Next i
Close #filesize
MsgBox "Done"
End Sub
'Function TempPath() As String
'TempPath = String$(MAX_PATH, Chr$(0))
'GetTempPath MAX_PATH, TempPath
'TempPath = Replace(TempPath, Chr$(0), "")
'End Function
When you use the statement ActiveWorkbook.SaveAs ... then you're going to save all worksheets at once. Instead, loop through the worksheets and save each one separately...
For Each Sheet In ActiveWorkbook.Sheets
Sheet.SaveAs Filename:=tmpFile, FileFormat:=xlText, CreateBackup:=False
' Open and process the file...
Next