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...
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 want to open Excel xlsx file without writing path by using variables. I din't know why but it is not working. I have a folder with the main workbook and another one that I want to open that is xlsx. I want to name it UnionWB.
Private Sub cmdStartMonth_Click()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
'Analyze month by selecting
Dim myPath As String
Dim myFile As String
Dim UnionWB As Workbook
Dim MonthName As String
MonthName = ListMonth.Value
myExtension = "*.xlsx*"
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Here's a couple of examples that may help.
The first will ask you to select the correct file and then open it:
Public Sub Test()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = GetFile(ThisWorkbook.Path)
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select your Union Workbook"
.AllowMultiSelect = False
.Filters.Add "My Union Workbook", "*.xlsx", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
The second method assumes you only have a single xlsx file in the same folder as ThisWorkbook and opens the first file it finds:
Public Sub OpenOnlyXLSXInFolder()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = Dir$(ThisWorkbook.Path & "\*.xlsx")
'Only expecting a single file so no need to loop.
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & "\" & sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
I'm trying to get the path for a folder using the filedialog.show function.
The issue I am facing is:
After I select a folder in the folderpicking window the code does not continue. It either restarts or it ends without anything happening.
What could be the problem?
[...]
Dim fpath As Variant
Dim fldr As Object
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
fldr.Title = "Select a Folder"
fldr.AllowMultiSelect = False
fldr.InitialFileName = Application.DefaultFilePath
If fldr.Show = -1 Then
fpath = fldr.SelectedItems(1)
Else
GoTo NextCode
End If
NextCode:
set fldr = Nothing
[...]
It works, you are just not using it to display the path result (or return a String value from this Sub).
Change your code:
If fldr.Show = -1 Then
fpath = fldr.SelectedItems(1)
Else
GoTo NextCode
End If
NextCode:
set fldr = Nothing
To:
If fldr.Show = -1 Then
fpath = fldr.SelectedItems(1)
MsgBox fpath ' <-- for DEBUG
End If
Set fldr = Nothing
If you want to use your code as a Function that returns the path of the selected folder, use the code below:
Function GetFolderPath() As String
Dim fpath As Variant
Dim fldr As Object
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show = -1 Then
GetFolderPath = .SelectedItems(1)
End If
End With
Set fldr = Nothing
End Function
And the Sub code to test it:
Sub Test()
Dim FolderPath As String
FolderPath = GetFolderPath
MsgBox FolderPath
End Sub
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.