my code prompts user to save the current file as a macro free file, the problem is that if the user hits cancel then i get an error. i need my code to start over when the user hits cancel. so it would be best if a message box pops up and says please select location to save file and then the dialog box pops up again so the user can select where to save file, and if user hits cancel again then just exit.
Sub SaveWithoutMacro()
Dim objFolder As Object, objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ChooseFolder)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=objFolder & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".xlsx", FileFormat:=51, password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
If objFolder <> False Then Exit SaveWithoutMacro = objFolder
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function ChooseFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to save down the copy of this workbook"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
If you want to avoid the error you have on "Cancel" (coming from the fact that you execute Set objFolder = objFSO.GetFolder(ChooseFolder) on an empty string (since ChooseFolder() returns empty if the user cancels the action) and at the same time ask him twice - why'd you want to ask them twice? - then you should write your macro like this:
Sub SaveWithoutMacro()
folderPath = ChooseFolder() '<-- ask them to select once
If folderPath = "" Then '<-- if they clicked cancel once
MsgBox "You didn't select a folder", vbCritical, "Are you sure?" '<-- message box to inform them
folderPath = ChooseFolder() '<-- ask them again to select
If folderPath = "" Then Exit Sub '<-- if again empty, then exit procedure
End If
'rest of your save code
I dont recommend doing this as it can really annoy the user, but basically you just put it into a Do Loop - something like this (untested)
With fldr
.Title = "Select a Folder to save down the copy of this workbook"
.AllowMultiSelect = False
.InitialFileName = strPath
Do Until .Show <> -1
If .SelectedItems(1) <> "" Then GoTo NextCode
Loop
End With
NextCode:
ChooseFolder = .SelectedItems(1)
Related
I've been working my way through a macro that will merge the first visible worksheet from an entire folder of selected workbooks. With plenty of help, I have the code working for the first worksheet in each workbook, but it is picking up hidden worksheets and I only want the first visible sheet. Here is the code so far:
Option Explicit
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = GetFolder("Navigate to folder")
FileName = Dir(Path & "\*.xl??", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName, ReadOnly:=True, UpdateLinks:=False)
Wkb.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
you can loop until a visible worksheet is found
Dim i As Long
i = 1
Do While Wkb.Worksheets(i).Visible = False
If i >= Wkb.Worksheets.Count Then
MsgBox "No visible sheet found"
Exit Do
End If
i = i + 1
Loop
Debug.Print Worksheets(i).Name 'first visible sheet
I wrote a macro that asks you the folder where to save all the graphs of a worksheet using a message box, but at the and the graphs are saved not in the desired folder, but in the parent one.
For example, instead of saving in C:\parent\desiredFolder it saves in C:\parent\
Thank you for your help.
Sub EXPORTCHARTS()
MsgBox ("Seleziona la cartella dove vuoi esoportare i grafici")
ActiveSheet.Select
ActiveWindow.Zoom = 400
Dim sItem As String
Dim dlgOpenFolder As FileDialog
Set dlgOpenFolder = Application.FileDialog(msoFileDialogFolderPicker)
dlgOpenFolder.Filters.Clear
With dlgOpenFolder
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = dlgOpenFolder
' ---------------------------------------------------------
Dim objCht As ChartObject
i = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export Filename:=i & ".jpg", FilterName:="JPG"
i = i + 1
Next objCht
' ---------------------------------------------------------
ActiveWindow.Zoom = 50
End Sub
Jbjstam pointed out in their answer that you aren't using the folder name when you are saving the files.
You also had issues with your logic if the user cancelled from the FileDialog as, even if you correctly used sItem in your loop, sItem would never be set and therefore the files would be being saved to the current directory.
The following should work:
Sub EXPORTCHARTS()
MsgBox ("Seleziona la cartella dove vuoi esoportare i grafici")
ActiveSheet.Select
ActiveWindow.Zoom = 400
Dim sItem As String
Dim dlgOpenFolder As FileDialog
Dim i As Long
Set dlgOpenFolder = Application.FileDialog(msoFileDialogFolderPicker)
dlgOpenFolder.Filters.Clear
With dlgOpenFolder
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then
MsgBox "No path selected"
Exit Sub
End If
sItem = .SelectedItems(1)
End With
' ---------------------------------------------------------
Dim objCht As ChartObject
i = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export Filename:=sItem & "\" & i & ".jpg", FilterName:="JPG"
i = i + 1
Next objCht
' ---------------------------------------------------------
ActiveWindow.Zoom = 50
End Sub
You don't use the variable fldr in the loop that exports the charts...
I am getting a basic error when I cancel the selection of a folder. I just want to Exit Sub when press the cancel button.
I'm using the following code
Set recsFolder = fso.GetFolder(Functions.GetFolder("C:\"))
Function GetFolder(strPath As String) As String
Dim Fldr As FileDialog
Dim sItem As String
Set Fldr = Application.FileDialog(msoFileDialogFolderPicker)
With Fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set Fldr = Nothing
End Function
A suggestion from one of the best source : http://www.cpearson.com/excel/browsefolder.aspx
Function BrowseFolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = msoFileDialogViewList)_
As String
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolder = CStr(V)
End Function
The error happen in
Set recsFolder = fso.GetFolder(Functions.GetFolder("C:\"))
Because your function GetFolder returns an empty string when you cancel the folder selection
QUick solution, just change your logic to this:
Dim strReturned As String
strReturned = Functions.GetFolder("C:\")
If strReturned <> "" Then
Set recsFolder = fso.GetFolder(strReturned)
End If
to bypass the Set recsFolder if the folder is empty
I've read all of your answers and thank you for them, but I couldn't manage to apply them. Instead I have used the error handling (which I know I should avoid, but it won't damage the code).
On Error GoTo ErrHandlr:
Set recsFolder = fso.GetFolder(Functions.GetFolder("C:\"))
ErrHandlr:
Exit Sub
There is a ready script that counts number of rows in Workbooks from a selected folder. In case number of rows in any workbook is more than 1, this workbook is copied and saved into another folder.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\user\Desktop")
MyFile = Dir(MyFolder & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile & "*.*")
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\user\Desktop\vba\" & MyFile
End If
.Close
End With
MyFile = Dir
Loop
'Workbooks.Close savechanges:=False
Shell "explorer.exe C:\Users\user\Desktop\vba", vbMaximizedFocus
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row
End Function
Is it possible to move a Worbook to another folder insted of coping it in case it contains more than 1 row.
And is it possible to use something like: Workbooks.Close savechanges:=False in order to close chosen Workbooks after rows counting? Thanks!
You can move a file easily using the MoveFile method of FileSystemObject object. To use this type with early binding add a reference to Microsoft Sripting Runtime in your VBA project.
I'm using VBA to create a FileOpenDialog object so that the user can select a directory. Here's my test code:
Function GetFolder(InitDir As String) As String
Dim fldr As FileDialog
Dim sItem As String
sItem = InitDir
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Please select a folder, then press OK to continue"
.AllowMultiSelect = False
If Right(sItem, 1) <> "\" Then
sItem = sItem & "\"
End If
.InitialFileName = sItem
If .Show = 0 Then
GetFolder = ""
Exit Function
End If
If .Show <> -1 Then
sItem = InitDir
Else
sItem = .SelectedItems(1)
End If
End With
GetFolder = sItem
Set fldr = Nothing
End Function
sub test()
dim selectedDir as variant
selectedDir=getFolder("c:")
msgbox selectedDir
end sub
But the dialog box created by this function requires that the user click OK twice to select whatever folder they've clicked on. Is there any way to make it so they only have to click OK once?
You call .Show() twice. So the dialog shows twice. Each time you only have to click OK once.
Call .Show only once and save the returned value to a variable to test later.