I'd like to check if a file located in my_path exists, if it does overwrite it with a file declared "garcat" containing 1 single sheet. Creating a file for the 1st time works, however overwriting it gives me this error 1004: Method 'SaveAs' of object'_Workbook' failed
Sub FileCreate(ByVal TGName As String)
Dim garcat As Workbook
Dim file As String
file = my_path
If Dir(file) <> "" Then
SetAttr file, vbNormal
Kill file
MsgBox "The file already exists, it will be replaced"
End If
Application.SheetsInNewWorkbook = 1
Set garcat = Workbooks.Add
garcat.SaveAs FileName:=file
MsgBox "File Saved"
garcat.Sheets(1).name = "GARCAT " & TGName
garcat.Close (True)
End Sub
EDIT: I set Application.DisplayAlerts = False and Application.EnableEvents = False before saving the file and I still get the pop-up error message.
This works by just telling the file to save regardless of any other factors: "And no back-talk! If there's already a file there... Just overwrite it."
Sub FileCreate(ByVal TGName As String)
Dim garcat As Workbook
Dim chemin As String
file = my_path
Application.SheetsInNewWorkbook = 1
Set garcat = Workbooks.Add
Application.DisplayAlerts = False
garcat.SaveAs FileName:=file
Application.DisplayAlerts = True
MsgBox "File Saved"
garcat.Sheets(1).name = "GARCAT " & TGName
garcat.Close (True)
Related
I am using an interface made with Excel to allow users to concurrently edit a shared data file. To prevent multiple users from editing at the same time I made the following function to do the following:
Open the file
If the file was opened as a read-only, close the file and re-open until the file is opened as read-write or the maximum number of allowed attempts is crossed.
Function OpenTillCanEditC(refpath As String, pw As String) As Workbook
Dim wbtoopen As Workbook
Dim maxOpen As Long
Dim i As Long
Dim buttonClicked As Long
maxOpen = 10
i = 0
On Error GoTo ErrHandler:
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
While wbtoopen.ReadOnly And i < maxOpen
If wbtoopen.ReadOnly Then
wbtoopen.Close (False)
Application.Wait (Now + TimeValue("00:00:01"))
Set wbtoopen = Nothing
i = i + 1
If i >= maxOpen Then
buttonClicked = MsgBox("It appears the masterlist is currently being used by someone else. Do you want to retry opening?", vbRetryCancel)
If buttonClicked = vbRetry Then
maxOpen = maxOpen + 10
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
End If
Else
On Error GoTo ErrHandler:
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
End If
End If
Wend
Set OpenTillCanEditC = wbtoopen
Exit Function
ErrHandler:
Application.DisplayAlerts = True
If Err.Number = 1004 Then
MsgBox "The password keyed in is wrong."
Else
MsgBox "The masterlist found in " & refpath & " cannot be opened. It may be used by someone else or corrupted. If corrupted please open the file manually using Excel."
End If
Set wbtoopen = Nothing
Set OpenTillCanEditC = wbtoopen
End Function
OpenTillCanEditC will be used in a sub for updating as shown below:
Sub UpdateFile()
'Try to open
Dim datawb As Workbook
Dim filepath As String
Dim pw As String
filepath = "C:\Folder Containing File\Data File.xlsx"
pw = "password"
Set datawb = OpenTillCanEditC(filepath, pw)
If datawb Is Nothing Then
MsgBox "File cannot be opened or is currently in use."
Exit Sub
End If
'Do functions needed in the workbook here
datawb.Save()
datawb.Close
End Sub
However I keep getting either of the following two errors:
When multiple people are attempting to access the file, the OpenTillCanEditC function will still ask for a password even though it is already being keyed in.
datawb.Save() will sometimes throw an error stating that the save failed due to multiple users accessing the file.
How do I fix both of these issues to allow multiple users to edit a shared password-protected file using VBA?
Not sure why I am getting this error. Please assist in correcting and also, provide a good explanation for the reason. I have 3 subs (from 2 modules) that call each other sequentially. Is the reason for the error message because the file name from the first sub is declared as a variable in the third sub? See code below:
Module1:
Option Explicit
Sub PRM_1_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_1_New As Workbook ' This is BCRS-PTASKS Unassigned.csv
Set PRM_1_New = Workbooks("BCRS-PTASKS Unassigned.csv")
Dim SaveDir1 As String, prmAfn As String
SaveDir1 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir1, vbDirectory)) = 0 Then MkDir SaveDir1
prmAfn = SaveDir1 & "\PRM_1_TEMP"
Application.SendKeys ("~")
PRM_1_New.SaveAs Filename:=prmAfn, FileFormat:=xlOpenXMLWorkbook
PRM_1_New.Close False
Call PRM_2_Report_Save
Application.ScreenUpdating = True
End Sub
Sub PRM_2_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_2_New As Workbook ' This is Problem WGM & WGL xref with description.xls
Set PRM_2_New = Workbooks("Problem WGM & WGL xref with description.xls")
Dim SaveDir2 As String, prmBfn As String
SaveDir2 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir2, vbDirectory)) = 0 Then MkDir SaveDir2
prmBfn = SaveDir2 & "\PRM_2_TEMP"
Application.SendKeys ("~")
PRM_2_New.SaveAs Filename:=prmBfn, FileFormat:=xlOpenXMLWorkbook
PRM_2_New.Close False
Application.ScreenUpdating = True
Call Open_PRM_Files
End Sub
Module 2:
Option Explicit
Sub Open_PRM_Files()
'
Application.ScreenUpdating = False
Dim PRM_Dir As String
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
Application.ScreenUpdating = True
End Sub
This line from the sub in Module2 is where the debugger shows the error (which is also commented in the sub above):
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
The purpose of the code here is to save two imported reports into .xlsx format, close them, and then open the files in the saved format. I need this to occur in separate subs (save and open) for other workflow processes of this VBA Project not listed (or relevant) here.
EDIT: I should also mention that the first two subs execute and provide the intended results which is each file saved in the new directory and with the proper extension.
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
This line assumes that you already have an open workbook with that name. If Excel does not find an open workbook with that name then you will get a runtime error as you noticed.
I'm assuming that you are trying to open the workbooks here which you created in the first two subs:
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
"& PRM_1_TEMP" is the name of a Workbook variable, and you're trying to concatenate it as a string name. Change this to a string matching the filename, and then move your declarations of workbooks to below the code that opens the workbooks. This way Excel opens the workbooks BEFORE trying to access them in the Workbooks collection, and you should not receive an error. I haven't tested this modification, but please let me know if it works for you.
Sub Open_PRM_Files()
Application.ScreenUpdating = False
Dim PRM_Dir As String
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_1_TEMP"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_2_TEMP"
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
Application.ScreenUpdating = True
End Sub
It is supposed to open the file, save as, copy values, Save as again (final filename), then to delete the first save as. I am using this to achieve a temporary .xlsx file. It works, opens, saves as window comes up, then deletes the Temp file but it is not saving the file before it deletes the temp file.
Code:
Sub PracticeMakesPerfect()
Dim wbMain As Workbook
Dim Alpha As Workbook
Dim Beta As Workbook
Dim sFile As String
Dim PurgeTemp
Application.DisplayAlerts = False
Set wbMain = Workbooks("Macro Tester.xlsm")
Set Alpha = Workbooks.Open("C:\Users\frfcomputer\Desktop\Test.xlsx")
ActiveWorkbook.SaveAs "C:\Users\frfcomputer\Desktop\test\Temp.xlsx"
Set Beta = Workbooks("Temp.xlsx")
wbMain.Sheets("Sheet1").Range("A1").Value = Beta.Sheets("Sheet1").Range("A1").Value
Application.DisplayAlerts = True
Application.GetSaveAsFilename
ActiveWorkbook.Close
'Source File Location
sFile = "C:\Users\frfcomputer\Desktop\test\" & "Temp.xlsx"
'Sets Object
Set PurgeTemp = CreateObject("Scripting.FileSystemObject")
'Checks File Exists or Not
If PurgeTemp.FileExists(sFile) Then
'If file exists, delete the file
PurgeTemp.DeleteFile sFile, True
MsgBox "Deleted The File Successfully", vbInformation, "Done!"
Else
'If file does not exists
MsgBox "Specified File Not Found", vbInformation, "Not Found!"
End If
End Sub
You're asking for a filename to save as with Application.GetSaveAsFilename but you're not putting it to use:
Sub test()
Dim a As String
a = Application.GetSaveAsFilename(FileFilter:="Excel Files, *.xls") 'Ask for a filename to save as.
ThisWorkbook.SaveAs a 'Save the file
End Sub
It's the end of the day, so haven't added everything - check that the result of a isn't FALSE or some other unusable name. There's also various options available under SaveAs.
MY GOAL: Batch convert all .TDM files in a folder to .XLS using an existing add-in by adapting this macro that only works 1 file at a time. (Also open to any VBA approach.)
Using an existing add-in, a single .TDM file is converted into a single .XLS workbook with multiple sheets.
I need to, instead of using a prompt to select a single .TDM file, automatically convert all .TDM files in a folder into new .XLS workbooks.
This is part of a multi-stage process. I tried various loops, mimicking other set-ups, and merging it with other code I found on various community boards.
FYI: .TDM files hold engineering data output produced by testing equipment.
Sub GetTDM_AddIn()
'Get TDM Excel Add-In
Dim obj As COMAddIn
Set obj = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
'obj.Connect = True
'Confirm only importing "Description" properties for Root
Call obj.Object.Config.RootProperties.DeselectAll
Call obj.Object.Config.RootProperties.Select("Description")
'Show the group count as property
Call obj.Object.Config.RootProperties.Select("Groups")
'Select all the available properties for Group
Call obj.Object.Config.GroupProperties.SelectAll
'Import custom properties
obj.Object.Config.RootProperties.SelectCustomProperties = True
obj.Object.Config.GroupProperties.SelectCustomProperties = True
obj.Object.Config.ChannelProperties.SelectCustomProperties = True
'Let the user choose which file to import
Dim fileName
fileName = Application.GetOpenFilename("TDM & TDMS (*.tdm;*.tdms),*.tdm;*.tdms")
If fileName = False Then
' User selected Cancel
Exit Sub
End If
'Import the selected file
Call obj.Object.ImportFile(fileName)
'Record down the current workbook
Dim Workbook As Object
Set Workbook = ActiveWorkbook
End Sub
Below is an Excel Macro (VBA Script) I wrote to do something very similar to what you want to do. It converts a directory of .tdms files to their equivalent .csv files. It requires the ExcelTDM Add In (NITDMEXCEL_2015-0-0.exe) which I obtained at http://www.ni.com/example/27944/en/. I tested the script in Excel 2013 running on a modest Windows 7 Pro machine converting 24 TDMS files with 120,000 rows each file. It completed the conversions without error in about 2 minutes 30 seconds which is about 7 seconds per file. Please forgive my hasty error handling and poor VBA form.
Sub ConvertTDMStoCSV()
'
' ConvertTDMS Macro
'
' Acts upon all .tdms files in a "source" directory,
' loading each one using the ExcelTDM Add In,
' deleting the first sheet and saving the
' remaining stream data as one .csv file
' in a "target" directory. Writes a list of
' the files converted in a new sheet.
'
' Tested to work with Excel 2013 on Windows 7
' with NITDMEXCEL_2015-0-0.exe obtained at
' http://www.ni.com/example/27944/en/
Dim sourceDir As String, targetDir As String, fn As String, fnBase As String
Dim fso As Object, n As Long, resp As Integer, strNow As String, newSheet As Object
Dim tdmsAddIn As COMAddIn, importedWorkbook As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set tdmsAddIn = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
tdmsAddIn.Connect = True
Call tdmsAddIn.Object.Config.RootProperties.DeselectAll
Call tdmsAddIn.Object.Config.ChannelProperties.DeselectAll
tdmsAddIn.Object.Config.RootProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.GroupProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.ChannelProperties.SelectCustomProperties = False
'Choose TDMS Source Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Source Directory of TDMS Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
sourceDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(sourceDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, sourceDir
Exit Sub
End If
'Choose CSV Target Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Target Directory for CSV Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
targetDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(targetDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, targetDir
Exit Sub
End If
fn = Dir(sourceDir & "\*.tdms")
If fn = "" Then
MsgBox "No source TDMS files found.", vbInformation
Exit Sub
End If
resp = MsgBox("Begin conversion of TDMS files?" & vbCrLf & sourceDir & vbCrLf & "to" & vbCrLf & targetDir, vbYesNo, "Confirmation")
If resp = vbNo Then
MsgBox "Execution cancelled by user."
Exit Sub
End If
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
strNow = WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss")
newSheet.Name = strNow
newSheet.Cells(1, 1).Value = "Files converted on " & strNow
newSheet.Cells(2, 1).Value = "TDMS Source Directory: " & sourceDir
newSheet.Cells(3, 1).Value = "CSV Target Directory: " & targetDir
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 5
Do While fn <> ""
fnBase = fso.GetBaseName(fn)
On Error Resume Next
Call tdmsAddIn.Object.ImportFile(sourceDir & "\" & fn, True)
If Err Then
MsgBox Err.Description, vbCritical
Exit Sub
End If
Set importedWorkbook = ActiveWorkbook
Application.DisplayAlerts = False
importedWorkbook.Sheets(1).Delete
importedWorkbook.SaveAs Filename:=targetDir & "\" & fnBase & ".csv", FileFormat:=xlCSV
importedWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
newSheet.Cells(n, 1).Value = fnBase
n = n + 1
fn = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
Set newSheet = Nothing
Set importedWorkbook = Nothing
End Sub
Instead of trying to do this in VBA, I suggest that you use powershell to get all of the files and then call the Excel macro, for each file, using the Run method.
You'll also need to modify the macro to either (1) run on the current open file (solution below); or (2) take a filename as an argument (this changes the call to Run below)
The code is something like this (modify the call to get-childitem to fit your applicaton):
$excel = new-object -comobject excel.application
$files = get-childitem ... #etc, collect your files into an array
foreach ($file in $files)
{
$wb = $excel.workbooks.open($file.fullname)
$ws= $wb.worksheets.item(1)
$ws.Activate()
$excel.Run("GetTDM_AddIn")
$wb.save()
$wb.close()
}
$excel.quit()
I used this simple app to convert tdms files.
It supports multiple files and has command line support.
http://www.whiterocksoftware.com/2019/11/batch-convert-tdms-to-excel.html
I'm in the process of setting up a Macro to open up all files in a directory and copy a certain tab from each into a combined file (merge them in one workbook). I have two problems. Firstly the files are password protected - So when I use this line it opens the file.
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName)
However when it's password protected it fails. So I added the following to the end but it still fails.
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName),Password = "openfile"
2nd issue - When I copy the tabs (sheets) in I want to name them with the file name I took them from. However the file name is too long - So I want to take the name up to the first space (e.g. "Test file May 13" = sheet name "Test"). How do I get this code to work.
Any help greatly appreciated.
Full code below:
* gRnCT_File_Loc = Directory location.
* gsInputFileName = File Name.
Code to date:
Sub Pulldata()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set gRwksconfigeration = Sheets(gcsConfigSheetName)
gRnCT_File_Loc = gRwksconfigeration.Range(CT_File_Loc)
gRnCT_Tab_Search = gRwksconfigeration.Range(CT_Tab_Search)
gsInputFileName = Dir(gRnCT_File_Loc)
Set gwkscurrent = ActiveWorkbook
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> gcsConfigSheetName Then ws.Delete
Next ws
Do
On Error GoTo err:
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName)
On Error GoTo 0
On Error GoTo err1:
With Sheets(gRnCT_Tab_Search)
On Error GoTo 0
End With
gsInputFileName = Dir
Loop Until gsInputFileName = vbNullString
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
err:
MsgBox ("No files or files in incorrect format in " & gRnCT_File_Loc)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
err1:
MsgBox ("Sheet " & gRnCT_Tab_Search & " doesn't exist in file " & gsInputFileName)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Resume Next
End Sub
For the 2nd question about getting the 1st part of the file name, try:
if(instr(gsInputFileName," ") > 0
then short_file_name=left(gsInputFileName,instr(gsInputFileName," ")-1)
else short_file_name=gsInputFileName
endif
You are missing a : after password
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName),Password = "openfile"
should be:
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName,Password:="openfile")
You could use split for your second problem using a space as your delimiter e.g.
Split(str, " ")(0)
where str is the original name of the file e.g. "Test file May 13"