Let's say I have a function that takes a value of a cell from one of the sheets and makes a copy of that file under that name in the specified directory:
Function SavePeerGroupAsFile(source_file, peer_group, file_path)
SavePeerGroupAsFile = source_file.SaveCopyAs(filename:=file_path & peer_group & ".xlsm")
End Function
I would like to be able to use it in my Main so that after the function is called, that workbook is set as a variable, so I could directly work on it and do some other stuff. To call it, in my Main, I'm using:
Set peer_wrk = SavePeerGroupAsFile(src_wrk, peer_group_name, peer_group_dir)
I can see the file saved under correct name in the right directory but right after function is called it throws an error:
Any idea how this should be done correctly?
You need to open the copied workbook:
Function SavePeerGroupAsFile( _
ByVal source_file As Workbook, _
ByVal peer_group As String, _
ByVal file_path As String _
) As Workbook
source_file.SaveCopyAs Filename:=file_path & peer_group & ".xlsm"
Set SavePeerGroupAsFile = Workbooks.Open(file_path & peer_group & ".xlsm")
End Function
Related
I have a master_macro that calls 2 other macros: (sub)calc and (sub)transfer. The calc macro doesn't need any variables passed to it, but the other one does and when the master_macro calls the transfer macro, there are several passed variables that are being modified even though they are passed using the byval method. these declarations are nested in a for loop because they are workbook names.
dpath = ws.cells(2,9).value
fname = ws.cells(i,10).value
set wkbk = workbooks.open(dpath & fname & ".xlsx")
call calc
tempname = ws.cells(4,9).value
fpath = ws.cells(3,9).value
temppath = ws.cells(5,9).value
set wkbk2 = workbooks.open(temppath & tempname) 'the tempname should have the extension
call transfer(fname, dpath, fpath, tempname, wkbk, wkbk2)
Here is how I start the transfer subroutine.
sub transfer(byval fname, byval dpath, byval fpath, byval tempname, byval wkbk, byval wkbk2)
I have breakpoints at the call point to step through it, to see what the variables are. Somehow the fpath and the tempname varialbes get switched. I was under the impression that if use byval they can't be changed. I noticed the error when once the transfer ran and broke at the 'next i' in the loop, it didn't save the tempname in the fpath folder.
I have made 2 small vba codes to get a file that is in a certain folder using vba. I need to write a vba code because the path where the referenced file exists changes based on the username. The data is extracted from the cells of the referenced file only when the file is left open when the referenced file is closed then I get an error "#VALUE". Can someone explain to be why this is happening.
the Vba code is not the problem, please see the codes below. Formula in a cell looks like
TXT2RNG(source_file("a5";"Line Sheet";"1607508-GEN-0047.xlsm"))
Public Function source_file(Optional ByVal rekke As String = "", _
Optional ByVal arknavn As String = "Line Sheet", _
Optional ByVal boknavn As String = "1607508-GEN-0047.xlsm")
Dim str As String
source_file = "'C:\BC-WorkSpace\" & UCase(Environ$("UserName")) _
& "\M-Ocd-for-meri2,D-IKM-01\Projects\1607508 BALDER FUTURE PROJECT – DETAIL DESIGN\Generic\Admin\[" & boknavn & "]" & _
arknavn & "'!" & rekke
End Function
Public Function TXT2RNG(text) As Variant
Set TXT2RNG = Range(text)
End Function
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
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.
I recently updated to office 2016 and now my macro that i am using to select a range in excel, and then convert this range to PDF and automatically send an email, does not fully work.
Before when i used this macro, the filename was automatically filled in the SaveAs dialog box, but now it is empty. I do not understand why.
Does anyone else has a problem like this or know how to fix it?
Here is my code:
Function Skicka_projektunderlag_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws = Sheets("Partner_information")
Set ws1 = Sheets("Kundinformation")
Set ws2 = Sheets("Kalkyl")
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename(ws.Range("B1").Value & " - Projektunderlag " & ws2.Range("BF104").Value & " " & ws1.Range("B3").Value _
, FileFilter:=FileFormatstr, Title:="Create PDF")
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
If Dir(Fname) <> "" Then Skicka_projektunderlag_PDF = Fname
End If
End Function
Best regards
AgatonSaxx
The following answer isn't refined but I have also been struggling with this problem in Word 2016 VBA to generate a default file name when Save As is selected in Word 2016
and wanted to share what I've found thus far as it is working with some success.
I was able to get the code semi-working again by adding an event handler.
Application.DocumentBeforeSave Event
example here https://msdn.microsoft.com/en-us/library/office/ff838299.aspx
tied to Using Events with Application Object
example here https://msdn.microsoft.com/en-us/library/office/ff821218.aspx
I moved my actual code to within the class module
Cancel=true
had to be added to the end of the code or the Save As dialog box would open twice.
This "solution" has some drawbacks that it only works once per document. So, if for some reason, you want to use SaveAs on the same document more than once, the name won't default. It also seems a bit clunky/limited for my taste but it is a start.
This "solution" is Word based but you should be able to do/ find something similar for Excel.
Hope this helps put you on the path to success. Apologies for not being a perfect answer. Just wanted to share lessons learned as maybe it will cut down on your time to a solution!