I used some code from Close an opened PDF after opening it using FollowHyperlink to create the following code to open a pdf file and rename it. The code runs fine but only if I break execution at MsgBox "Break Here" and step into it with the F8 key. Any ideas on why it won't execute automatically?
Sub OpenPDF()
'Opens PDF Scaned file & saves it to another folder
'***ErrorHandler***
On Error Resume Next
'***Declare Objects****
Dim objectWMI As Object
Dim objectProcess As Object
Dim objectProcesses As Object
Dim Path As String
Dim MyDir As String
'***Opens a new workbook if there are no active workbooks***
'***There must be an active workbook for FollowHyperlink to function***
nowbs = Application.Workbooks.Count
If nowbs = 1 Then
Application.Workbooks.Add
Else
End If
'***Saves current Excel path
MyDir = CurDir
'***Sets path to Ricoh Scans
PDFDir = "S:\Ricoh Scans"
ChDir PDFDir
'***Gets filename for PDF scan
Path = Application.GetOpenFilename(filefilter:="PDF file (*.pdf), *.pdf")
'***Opens PDF file***
ActiveWorkbook.FollowHyperlink Path
'***Sets Excel as active application
AppActivate "Microsoft Excel"
'***Prompts for PO number****
MyPONum = InputBox("Enter PO Number", "PO Editor", "30500")
'***If user selects Cancel on inputbox then xl closes Acrobat and exits sub
If MyPONum = vbNullString Then
GoTo EndAll
Else
End If
'***Replaces scanned filename with inputbox filename
PathLen = Len(Path)
OldName = Mid(Path, 16, PathLen - 19)
NewName = "S:\Materials Management\Purchase Orders\PO " & MyPONum & ".pdf"
EndAll:
'***Set Objects***
Set objectWMI = GetObject("winmgmts://.")
Set objectProcesses = objectWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Acrobat.exe'") '< Change if you need be ** Was AcroRd32.exe**
'
'
'Code executes fine up to here but must Ctrl + Break at this line
'and F8 step thru balance of code or it will not work
'
'
MsgBox "Break Here"
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
Call objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
Thanks to all for your input. I'm not a programmer and as I said I used code that had been posted elsewhere on this site. It was a timing issue and this edit works.
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***************
Application.Wait (Now + TimeValue("00:00:02"))
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
Related
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 am trying to write a macro that retrieves data from an ALV grid in SAP GUI. Everything is working fine up until the data exports. When exporting data from ALV grid to an .xlsx file, the file will automatically open after it exports.
I need my script to wait for the export to open, and then copy the data from the newly opened export file to the .xlsm file that the script is coming from.
If I try to activate the export.XLSX file immediately following the command to export the file in SAP GUI, I get a "subscript out of range" error. I thought maybe I could loop the activate command until it stops erroring (while the export.xlsx file is opening) but that causes excel to crash. What should I do?
Function funcLSAT(strEnv)
Dim wkbExport As Workbook
Dim strError As String
If Not IsObject(SapGuiApp) Then
Set SapGuiApp = CreateObject("Sapgui.ScriptingCtrl.1")
End If
If Not IsObject(Connection) Then
Set Connection = SapGuiApp.OpenConnection(strEnv, True)
End If
Set session = Connection.Children(0)
session.findById("wnd[0]/tbar[0]/okcd").Text = "[TCODE]"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/tbar[1]/btn[8]").press
session.findById("wnd[0]/tbar[1]/btn[8]").press
session.findById("wnd[0]/usr/cntlG_CC_MCOUNTY/shellcont/shell").pressToolbarContextButton "&MB_EXPORT"
session.findById("wnd[0]/usr/cntlG_CC_MCOUNTY/shellcont/shell").selectContextMenuItem "&XXL"
session.findById("wnd[1]/usr/ctxtDY_PATH").Text = "[filepath]"
session.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = "export.xlsx"
session.findById("wnd[1]/tbar[0]/btn[11]").press
Set session = Nothing
Set Connection = Nothing
Set SapGuiApp = Nothing
Do
On Error Resume Next
Windows("export.XLSX").Activate
Loop Until (Err.Number = 0)
On Error GoTo 0
Range("A2:AS2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End Function
I had the same issue time ago when my macro had to wait for a .txt to be created and then continue so I found this:
Dim Directory As String, File As String
Directory = ActiveWorkbook.Path & "\" 'path for the file
File = Directory & "datos.txt" 'name of the file along with the path
FindIt = Dir(File)
While Len(FindIt) = 0
FindIt = Dir(File)
Wend
Hope it helps.
Here is what I do to export as XSLX, copy over the sheet, and close.
Application.wait does not do what you would want it to do here. Application.wait does not release Excel and so the SAP file never opens. Setting a timer will release Excel so the file will load.
It may not be the most well written, but it works. First, do a function to be able to see if the files are open or not. Then, set a timer of 0.5 seconds or so to put on a loop. You could do a longer timer and probably wouldn't have to loop, but done with a short time keeps Excel from being released any longer than it has to. Once the file locked on to, it will copy over the contents and close the file, and will exit the loop. Then I also kill the file because, on next run, it needs to be gone if the first run the isfile open is going to pick up the old file. This is written to where it's supposed to grab the workbook if it's opened in another instance—though, I haven't tested that. The way my VBA workbook loads, SAP files end up loading in the same instance. Good Luck!
Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
Dim xlfile as string, xldir as string
Dim PauseTime, Start
Dim control As Long
Dim xlapp As Object
Dim wb as workbook
xldir= "Your file folder path here"
control = 0
xlfile = "Your filename here"
Do Until control = 5
PauseTime = 0.5 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
If control = 1 And IsFileOpen(xldir & xlfile) = False Then
Exit Do
End If
If IsFileOpen(xldir & xlfile) = True Then
Set xlapp = GetObject(xldir & xlfile).Application
If control = 0 Then
Workbooks(xlfile).Sheets(1).Name = Left(xlfile, Len(xlfile) - 5)
Workbooks(xlfile).Sheets(Left(xlfile, Len(xlfile) - 5)).Copy
before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Activate
control = 1
End If
For Each wb In Application.Workbooks
If wb.Name = xlfile Then
wb.Close
End If
Next wb
End If
Loop
control = 0
kill(xldir&xlfile)
I am trying to make the following code work for saving a file name in a certain format. I would like it to save in the folder the file was opened up in. the file would change it's name to a new month name. I have got most of it working, such as directory selection and filename and for it to save, however, if there is already a file with the same name or if someone selects no or cancel it gives an error. I have tried various ways of trying to get around it but now I'm at a loss. I have 2 codes they both are supposed to do the same thing, just variations.
Sub saving1()
' Saves the file under a new name based on the new month date.
Dim NewFilename As String
Dim tempnm
Dim loc ' variable for file location
loc = Application.ThisWorkbook.Path 'loads the file location on the loc variable
MsgBox loc
' creates the file name for saving includes the current path.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
'tempmm = Application.GetSaveAsFilename initialfilename
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
'Application.DisplayAlert = False
'On Error Resume Next 'to omit error when cancel is pressed
' MsgBox "Not saved"
'ActiveWorkbook.Save
'If Err.Number <> 1004 Then 'optional, to confirmed that is not saved
' MsgBox "Not saved"
'End If
' On Error GoTo 0 'to return standard error operation
End Sub
Sub saving()
' Saves the file under a new name based on the new month date.
Dim NewFilename As String
Dim loc ' variable for file location
loc = Application.ThisWorkbook.Path 'loads the file location on the loc variable
' creates the file name for saving includes the current path.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
End Sub
I also added message boxes to try see what it is doing during testing. I have also tried the Getsaveasfilename in order to give the user an option to choose his/her own filename and possibly folder. The file location will change once a year.
If Your are looking at overwriting existing file, when there's already a file with same name try below.
NewFilename = loc + "\" + Range("NewFileName").Value & ".xlsm"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs NewFilename, FileFormat:=52
Application.DisplayAlerts = True
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.
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