I have a Macro that applies some filters and then exports certain columns as a PDF file, currently the Macro saves the PDF in the same folder as the Excel file but I would like it to ask me where I want to save the file instead, is this possible?
Any help much appreciated! :)
Sub FilterSaveCases()
With ActiveSheet.PageSetup
.LeftHeader = "&B& &20 Doff Stock : " & Format(Now, " ddmmyyyy")
On Error Resume Next
Columns("H:H").AutoFilter.ShowAllData
Columns("H:H").AutoFilter
ActiveSheet.Range("H:H").AutoFilter Field:=1, Criteria1:=">1"
Columns("C:O").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = False
ActiveSheet.Pictures("Picture 1").Visible = False
Dim Nm As String
Dim Rng As Range
Set Rng = Range("A1:P198")
Nm = ActiveWorkbook.FullName
Nm = Left(Nm, InStrRev(Nm, ".") - 1) & Format(Now, " ddmmyyyy") & ".pdf"
Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Nm, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=True
ActiveSheet.ShowAllData
Columns("C:O").EntireColumn.Hidden = False
Columns("M:M").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
ActiveSheet.Pictures("Picture 1").Visible = True
End With
End Sub
Yes, it is possible. Add this to your code. It will ask the user to select a location to save the file.
Sub download_location()
Dim user As String
Dim fldr As FileDialog
Dim sItem As String
Dim getfolder As String
user = Application.UserName
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
getfolder = sItem
Set fldr = Nothing
'do something here
End Sub
Related
I have the code below that I would like to run to all of the available excel files in a folder. Ideally, I would like to input the path of the folder into cell C3 in Sheet1 and the macro to apply the code to all of the existing files.
The code will simply save the second sheet of each file into a PDF version, it works perfectly standalone.
Sample Folder Path:
C:\Users\MMMM\Desktop\Project X\ Project II
Suggestions on how to approach this?
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Dim ReportSheet As Worksheet
Dim allColumns As Range
Set allColumns = Sheets("RT").Columns("N:S")
allColumns.Hidden = True
With Worksheets("RT").PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
Filename = ActiveWorkbook.Name
Cell = Replace(Filename, ".xlsx", ".PDF")
Set ReportSheet = Sheets("RT")
Sheets("RT").Select
Sheets("RT").PageSetup.Orientation = xlLandscape
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=True
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
This needs a reference (see this link)
It's untested (so let me know if anything comes up)
Basically:
As suggested by SmileyFtW it asks you for the root folder
Scans the subfolders for excel files (adjust the extension in code)
Process the DoSomething procedure where you export the file
EDIT: Added handle user cancel file select dialog
Code:
Option Explicit
' Add a reference to Microsoft Scripting Runtime
' See https://vbaf1.com/filesystemobject/create-microsoft-scripting-runtime-library-reference/
Private Sub ProcessAllFilesInFolder()
Dim FileSystem As Scripting.FileSystemObject
Dim fileDialogResult As Office.FileDialog
Dim folderPath As String
Set FileSystem = New Scripting.FileSystemObject
Set fileDialogResult = Application.FileDialog(msoFileDialogFolderPicker)
With fileDialogResult
.AllowMultiSelect = False
.Title = "Select a folder"
If .Show = True Then
folderPath = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
End With
ProcessFolder FileSystem.GetFolder(folderPath)
End Sub
Private Sub ProcessFolder(ByVal targetFolder As Scripting.Folder)
Dim FileSystem As Scripting.FileSystemObject
Dim File As Scripting.File
Dim SubFolder As Scripting.Folder
Set FileSystem = New Scripting.FileSystemObject
For Each SubFolder In targetFolder.SubFolders
ProcessFolder SubFolder
Next
For Each File In targetFolder.Files
If FileSystem.GetExtensionName(File.Name) Like "xls?" And File.Name <> ThisWorkbook.Name Then
DoSomething File.Path
End If
Next
End Sub
Private Sub DoSomething(ByVal filePath As String)
Dim FileSystem As Scripting.FileSystemObject
Dim ReportSheet As Worksheet
Dim targetFileName As String
targetFileName = Replace(ThisWorkbook.Name, ".xlsm", ".PDF")
Set ReportSheet = ThisWorkbook.Worksheets("Sheet2")
ReportSheet.PageSetup.Orientation = xlLandscape
ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & targetFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=True
End Sub
Let me know if it works!
I have a code that I found to loop through all of the files in the folder named Loop_AllWordFiles_inFolder and it calls whatever code you put in to execute some kind of action on the word documents in your selected folder. This code will run.
However I run into a problem when I try to have it call upon the code.. I don't know how to make them run together. The code it's calling is called ExtractSubject which is the action I need executed. I found this code online which runs through one file at a time and I'm trying to combine it with the looping files.
I'm new to VBA and I'm not sure how to fix the ExtractSubject code so they can run together. My end goal is to have two columns one with the title of the file and then beside it in the next cell the subject which I will be extracting. Something like this 1
Also I can't open a file without this read-only pop-up2 so if anyone knows how to fix that it would be appreciated but this is not my main concern atm.
Here's the two codes:
Option Explicit
Dim wb As Workbook
Dim path As String
Dim myFile As String
Dim myExtension As String
Dim myFolder As FileDialog
Dim wdApp As Object, wddoc As Object
Sub Loop_AllWordFiles_inFolder()
Set wdApp = CreateObject("Word.Application")
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With myFolder
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
path = .SelectedItems(1) & "\"
End With
' if the User select "Cancel"
NextCode:
path = path
If path = "" Then GoTo ResetSettings
' Target File Extension
myExtension = "*.doc"
' Target Path with Ending Extention
myFile = Dir(path & myExtension)
' Loop through all doc files in folder
Do While myFile <> ""
Set wddoc = wdApp.Documents.Open(fileName:=path & myFile)
' HERE you call your other routine
Call ExtractSubject
wddoc.Close SaveChanges:=False
myFile = Dir
Loop
Application.DisplayAlerts = PrevDispAlerts
MsgBox "Finished scanning all files in Folder " & path
ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set wdApp = Nothing
End Sub
Sub ExtractSubject()
Dim cDoc As Word.Document
Dim cRng As Word.Range
Dim i As Long
i = 2
Dim wordapp As Object
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open "c:\code practice\file1"
wdApp.Visible = True
Set wddoc = ActiveDocument
Set cRng = wddoc.Content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
.Execute
'Collapses a range or selection to the starting or ending position
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
Cells(i, 1) = cRng
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Execute
i = i + 1
End With
wordapp.Quit
Set wordapp = Nothing
End Sub
I think something like this should be close to what you're trying to do. Note you don't want all your variables as Globals - anything which needs to be shared between methods can be passed as an argument or returned as a function result.
Sub Loop_AllWordFiles_inFolder()
Const FILE_EXT As String = ".doc"
Dim wb As Workbook
Dim path As String
Dim myFile As String, theSubject As String
Dim wdApp As Object, wdDoc As Object
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show = -1 Then path = .SelectedItems(1) & "\"
End With
If Len(path) = 0 Then Exit Sub
'path = "C:\Temp\Test\" 'testing only
myFile = Dir(path & "*" & FILE_EXT) ' Target Path with Ending Extention
If Len(myFile) = 0 Then
MsgBox "No Word files found"
Exit Sub
End If
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Optimize '(don't really need this for this code though...)
Do While myFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=path & myFile)
theSubject = ExtractSubject(wdDoc) 'extract subject from wdDoc
wdDoc.Close SaveChanges:=False
If Len(theSubject) > 0 Then 'subject was found?
Name path & myFile As path & theSubject & FILE_EXT 'rename the file
Else
'output any problems
Debug.Print "Subject not found in '" & path & myFile & "'"
End If
myFile = Dir 'next file
Loop
wdApp.Quit 'no need to set to Nothing
Optimize False 'turn off speed enhancements
'Application.DisplayAlerts = PrevDispAlerts '?????
MsgBox "Finished scanning all files in Folder " & path
End Sub
'Return text between "SUBJECT:" and "JOB" in word document `wdDoc`
Function ExtractSubject(wdDoc As Word.document) As String
Dim cRng As Word.Range
Set cRng = wdDoc.content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
If .Execute() Then
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
ExtractSubject = Trim(cRng.Text)
End If
End With
End Function
'make changes to application settings to optimize macro speed in excel
Sub Optimize(Optional goFast As Boolean = True)
With Application
.ScreenUpdating = Not goFast
.EnableEvents = Not goFast
.Calculation = IIf(goFast, xlCalculationManual, xlCalculationAutomatic)
End With
End Sub
Try taking a look at this and see if it helps. From what I understand you are just trying to call one function in the middle of another.
From the first sentence of that link: "To call a Sub procedure from another procedure, type the name of the procedure and include values for any required arguments."
I am running into an issue with the code below. The "Cash Flow" sheet will not change the height to fit onto one page. When I use a breakpoint it works but that line seems to be skip when running the macro.I have tried using Application.Wait but that did not work. Any thoughts on how I can fix it? Thanks in advance!
Section of the code that is not working:
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
Full Code:
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
`enter code here` If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Sets Page Height ad Width
Dim myArray() As Variant
Dim i As Integer
For i = 1 To Sheets.Count
ReDim Preserve myArray(i - 1)
myArray(i - 1) = i
Next i
Sheets(myArray).Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 0
End With
Sheets("Cash Flow").Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Name)
'create default name for savng file
strFile = strName & ".pdf"
strPathFile = strPath & strFile
'export to PDF in current folder
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I'm trying to unmerge and duplicate data for a folder of xlsx files.
Separately, both macros work as intended. When I combine the macros (through "Call"), it executes but then brings me back to the macro screen. It doesn't give me any errors, but I need to close excel to start over.
I'm guessing the "UnMergeFill" macro isn't playing nice with being opened automatically?
I've tried using "call" and also with just the name of the sub. I've also tried separating the subs into different modules.
Sub AllWorkbooks()
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
MyFile = Dir(MyFolder)
Do While MyFile <> “”
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
UnMergeFill
wbk.Close savechanges:=True
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Call Sub UnMergeFill()
Dim cell As Range, joinedCells As Range
For Each cell In ThisWorkbook.ActiveSheet.UsedRange
If cell.MergeCells Then
Set joinedCells = cell.MergeArea
cell.MergeCells = False
joinedCells.Value = cell.Value
End If
Next
End Sub
'''
Try This:
Sub AllWorkbooks()
Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
MyFile = Dir(MyFolder)
Do While MyFile <> “”
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
Call UnMergeFill(wbk)
wbk.Close savechanges:=True
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub UnMergeFill(wb As Workbook)
Dim cell As Range, joinedCells As Range
For Each cell In wb.ActiveSheet.UsedRange
If cell.mergeCells Then
Set joinedCells = cell.MergeArea
cell.mergeCells = False
joinedCells.Value = cell.Value
End If
Next
End Sub
Struggling with the above question.
I have code which can load all of the files from a folder into a spreadsheet. I need to make it so the user can pick a folder rather than the path already being defined in the code.
Below is the code I already have, any guidance will be appreciated.
Sub From_IDPXML_To_ExcelReport()
On Error GoTo errh
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim myPath
myPath = "File path here”
Dim myFile
myFile = Dir(myPath & "*.xml")
Dim t As Long, N As Long, row As Long, column As Long
t = 2
N = 0
Application.ScreenUpdating = False
Do While myFile <> ""
N = N + 1
Set WB = Workbooks.OpenXML(Filename:=myPath & myFile)
If N > 1 Then
row = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
column = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).column
WB.Sheets(1).Range(Cells(3, "A"), Cells(row, column)).Copy myWB.Sheets(1).Cells(t, "A")
Else
WB.Sheets(1).UsedRange.Copy myWB.Sheets(1).Cells(t, "A")
End If
WB.Close False
t = myWB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row + 1
myFile = Dir()
Loop
Application.ScreenUpdating = True
myWB.Save
Exit Sub
errh:
MsgBox "no xml files in folder specified"
End Sub
Thanks.
Sure, replace:
myPath = "File path here”
with:
myPath = GetFolder()
and include this UDF in you module:
Public Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem & "\"
Set fldr = Nothing
End Function
The easiest, most simple code to have user select a directory is:
Sub dir_browser()
Set dir_chooser = Application.FileDialog(msoFileDialogFolderPicker)
dir_chooser.Show
picked_dir = dir_chooser.SelectedItems(1)
End Sub