I am writing a VBA macro to convert excel workbooks to PDF.
The wkb.PrintOut method works fine for some excel files. But for the others, it will print the first worksheet to the file name I supplied, and prompt me for the file name to save for the remaining worksheets.
Why does the PrintOut function behaves such a way? How do I let it print the entire workbook into a single file name I set?
Public Sub ConvertToPDF()
Dim ws As Worksheet
Dim inputQueue As Collection
Dim outputQueue As Collection
Dim r As Integer, c As Integer
Dim objFSO As FileSystemObject
Dim objInputFolder As Folder
Dim objOutputFolder As Folder
Dim objInputFile As File
Dim fileExt As String
Set ws = Worksheets("XLPrint")
Set objFSO = New FileSystemObject
Set inputQueue = New Collection
Set outputQueue = New Collection
Application.ActivePrinter = "Microsoft Print to PDF on Ne02:"
Application.DisplayAlerts = False
r = ws.Range("folder_name").Row + 1
c = ws.Range("folder_name").Column
ClearCollection inputQueue
ClearCollection outputQueue
While (ws.Cells(r, c).Value <> "")
inputQueue.Add objFSO.GetFolder(ws.Cells(r, c).Value)
outputQueue.Add objFSO.GetFolder(ws.Cells(r, c + 1).Value)
r = r + 1
Wend
Application.ScreenUpdating = False
Do While inputQueue.Count > 0
Set objInputFolder = inputQueue(1)
inputQueue.Remove 1
Set objOutputFolder = outputQueue(1)
outputQueue.Remove 1
For Each objInputFile In objInputFolder.Files
fileExt = Mid(objInputFile.ShortName, InStr(objInputFile.ShortName, ".") + 1)
Select Case UCase(fileExt)
Case "XLSX", "XLSM", "XLS"
Call PrintXLToPDF(objInputFile, objOutputFolder)
Case "DOCX", "DOC"
Call PrintWordToPDF(objInputFile, objOutputFolder)
End Select
Next objInputFile
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objFSO = Nothing
Set ws = Nothing
Set inputQueue = Nothing
Set outputQueue = Nothing
MsgBox "Done"
End Sub
Public Sub PrintXLToPDF(ByVal objInputXL As File, ByVal objOutputFolder As Folder)
Dim wkb As Workbook
Dim outputFileName As String
Set wkb = Workbooks.Open(objInputXL.Path)
outputFileName = objOutputFolder.ShortPath & "\" & Mid(objInputXL.Name, 1, InStr(objInputXL.Name, ".") - 1) & ".pdf"
wkb.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False, PrToFileName:=outputFileName, ActivePrinter:="Microsoft Print to PDF on Ne02:"
wkb.Close SaveChanges:=False
Set wkb = Nothing
End Sub
Try just saving it directly as PDF instead of printing:
wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
Many thanks
I combined the Plagon's answer and the answer of the
HackSlash and my problem was solved
The problem is solved when yuo save the Woorkbook (ActiveWorkbook.Save) and then use the line suggested by HackSlash (wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
)
Related
I am trying to rename all workbooks in a folder, based on the value of a cell in each file (basically reports dates). The xls files are saved from the internet in a folder. I wrote the code below but it's not working... workbooks.open fail and wb.name seems to not work either.
Sub openrenamebook()
Dim FileExtension As String, FilesInFolder As String
Dim FolderPath As String
Dim wb As Workbook
FileExtension = "*xls"
FolderPath = "N:\MyFolder\"
FilesInFolder = Dir(FolderPath & FileExtension)
Do While FilesInFolder <> ""
Set wb = Workbooks.Open(Filename:=FolderPath & FilesInFolder, ReadOnly:=False)
wb.Name = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
wb.Close True
FilesInFolder = Dir
Set wb = Nothing
Loop
End Sub
You cannot rename a file by changing the Workbook Name property. But you can use the FileSystemObject.
A reference to Microsoft Scripting Runtime is required for this code to work.
I cannot fully test because I do not know what file paths are specified in your worksheet. It assumes they're valid
Sub Test()
Dim FSO As New FileSystemObject
Dim FileItem As File
Dim wb As Workbook
Dim strRenameValue As String
FolderPath = "N:\MyFolder\"
'Loop Files
For Each FileItem In FSO.GetFolder(FolderPath).Files
Set wb = Workbooks.Open(FileItem.Path)
'Get The Value With Which To Rename The Workbook
strRenameValue = Mid(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
'You shouldn't need to save?
wb.Close False
'Now That The File Is Closed, Rename It
FileItem.Name = strRenameValue
Set wb = Nothing
Next FileItem
End Sub
Since you plan to rename the files, I would suggest that you start by loading all the names into an array before renaming the files, in order to get coherent values from Dir.
I do that using the following function:
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
This version uses a separate instance for speed (I did consider using ADO instead).
Also ensures only Excel files are opened and that the new filename is valid (I do assume that you have a valid suffix file type, ie .xlsx in your cell names)
Sub openrenamebook()
Dim xlApp As Excel.Application
Dim FileExtension As String
Dim FilesInFolder As String
Dim FolderPath As String
Dim strRenameValue As String
Dim wb As Workbook
Set xlApp = New Excel.Application
With xlApp
.Visible = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
FileExtension = "*.xls*"
FolderPath = "c:\temp\"
FilesInFolder = Dir(FolderPath & FileExtension)
Do While Len(FilesInFolder) > 0
Set wb = xlApp.Workbooks.Open(FolderPath & FilesInFolder)
On Error Resume Next
strRenameValue = Mid$(wb.Sheets(1).Cells(1, 2).Value, 38, 2)
On Error GoTo 0
wb.Close False
If Len(strRenameValue) > 0 Then Name FolderPath & FilesInFolder As FolderPath & strRenameValue
Set wb = Nothing
FilesInFolder = Dir
Loop
xlApp.Quit
Set xlApp = Nothing
End Sub
I have this code that gets the filenames on the selected directories.
Sub browsefile()
Dim file As Variant
Dim i As Integer
Dim lRow As Long
Set main = ThisWorkbook.Sheets("Main")
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
For i = 1 To UBound(file)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
Next i
End Sub
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Once I've selected the files, I have to put it in Column O. I have tried using .FullName but is not applicable in this area or maybe I've just misused it. Then later this will be send as attached file in an email in outlook.
By the way, I've got some of its code here.
Any help?
In Outlook include attachments with Attachments.Add
Private Sub browsefile_Att()
' Multiselect = False so file is not an array
' Dim file As Variant
Dim file As String
Dim lRow As Long
Dim main As Worksheet
Dim olOlk As Object
Dim olNewmail As Object
Set main = ThisWorkbook.Sheets("Main")
' Multiselect = False so file is not an array
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , False)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = file
Set olOlk = CreateObject("Outlook.Application")
Set olNewmail = olOlk.CreateItem(olMailItem)
olNewmail.Attachments.Add file
olNewmail.Display
ExitRoutine:
Set olNewmail = Nothing
Set olOlk = Nothing
End Sub
I assume you are trying to obtain the full path to the file that you have selected. Application.GetOpenFilename already returns you that and hence, there is no need to reprocess your file with GetFileName function?
Changing
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
To
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
should work assuming i have understood your question correctly. Hope this helps!
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore
I have below Excel procedure I gather up and I am using it for couple of different calculations under different workbooks. So I was thinking instead changing the procedure for main and outcome files each time, I should be able to pick the file I want to carry out calculations in and the file path for outcomes files.
But I could not find anything for saving directory, I appreciate if you could help
Sub AsBuiltForm()
Dim SaveName As String
Dim mainBook As Workbook
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
Workbooks.Open Filename:="C:\" 'main file can be browsed?
Set mainBook = Excel.Workbooks("CP.xlsx")
For i = a - 1 To b - 1
mainBook.Sheets(1).Range("bi1") = i + 1
SaveName = Sheets(1).Range("bi1").value & ".xlsx"
mainBook.SaveCopyAs "C:\" & SaveName 'save directory?
Workbooks.Open Filename:="C:\" & SaveName 'save directory?
With Excel.ActiveWorkbook
.Sheets("1 of 2").Range("A1:CT103").value = Sheets("1 of 2").Range("A1:CT103").value
.Sheets("2 of 2").Range("A1:CT103").value = Sheets("2 of 2").Range("A1:CT103").value
Excel.Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("il oufall").Delete
.Sheets("1 of 2").Select
Columns("Bh:BZ").Select
Selection.Delete Shift:=xlToLeft
.Sheets("2 of 2").Select
Columns("Bn:BZ").Select
Selection.Delete Shift:=xlToLeft
.Close True
End With
Next
mainBook.Close False
Set mainBook = Nothing
End Sub
You can use Application.GetOpenFileName to pick files that you want to open at Run-Time.
You can use the function below to browse for a folder where you wish to save a file.
Sub FindFolder()
Dim myFolder as String
myFolder = BrowseFolder("Pick a Folder Where to Save")
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.path
End If
End If
End Function
The following is not really an answer to your question, but a few tips to improve your code, and too long to add as a comment.
Workbooks.Open returns a Workbook object you can save the reference, so you don't have to rely on ActiveWorkbook:
Dim oWorkbook As Workbook
Set oWorkbook = Workbooks.Open(Filename:="C:\" & SaveName)
'***** Do something with oWorkbook
Debug.Print oWorkbook.FullName
Set oWorkbook = Nothing
A few other hints:
Use Option Explicit at the top of every module to force explicit declaration of all variables in order to find typos and other errors earlier.
Avoid selecting cells
Yes, browsing file works now; all the ins and outs aside, the problem i face with naming the file due to the variable "bi1" and saving as many loop as i asked for. I check several times before i bother you but i do not think i have the sufficient info to address "fn" as file in the use of Application.GetOpenFileName .
Option Explicit
Sub AsBuiltForm()
Dim fn
Dim myFolder As String
Dim SaveName As String, a As Integer, b As Integer, i As Integer
myFolder = BrowseFolder("Pick a Folder Where to Save")
MsgBox "Choose Calculation File "
fn = Application.GetOpenFilename
Workbooks.Open fn
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
For i = a - 1 To b - 1 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:=fn
Range("bi1") = i + 1
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Sheets(1).Range("A1:CT103").value = Sheets(1).Range("A1:CT103").value
Sheets(2).Range("A1:CT103").value = Sheets(2).Range("A1:CT103").value
Application.ActiveWorkbook.SaveAs myFolder & SaveName
ActiveWorkbook.Close True
Next
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.Path
End If
End If
End Function