I need to create a VBA macro when workbook opens, and create a desktop folder on /FATURAS.
If that folder not exist, open message box with information that folder was created, if already exist, ignore and do not alert message.
Private Sub Workbook_Open()
Dim cOb As Variant
Dim FolderName As String, FolderExists As String
FolderName = "C:\Users\AAAAA\Desktop\A New Folder" '---->Change folder name to suit. Change the AAAAA to your requirement.
FolderExists = Dir(FolderName, vbDirectory)
Application.ScreenUpdating = False
If FolderExists = vbNullString Then
MsgBox "The desktop folder doesn't exist. Creating a new folder now.", vbExclamation, "INFORMATION"
cOb = CreateObject("wscript.shell").specialfolders("Desktop") & "\" & "A New Folder" '--->Change folder name to suit.
MkDir cOb
Else: Exit Sub
End If
Application.ScreenUpdating = True
End Sub
Related
Good day guys, I created a form in MS Access and I am trying to write some codes that prevents duplication of files when it is added to a listbox. As it is now, if I select the folder of interest and click on Display button, it re-adds the same files already in the listbox. Please advise. Below is my code so far:
Public Sub btn_folderimp_Click()
' Displays Excel SpreadSheets In Selected Folder
Dim myFSO As New FileSystemObject
Dim MyFile As File
Dim mFolder As Folder
' Dim lbx As ListBox
'Checks If No Folder Was Selected
If Nz(Me.txt_folderpath, "") = "" Then
Beep
MsgBox "No Folder Selected!"
Exit Sub
End If
'Checks If Folder Exists, If Yes, it displays a list of spreadsheets in the Folder
If myFSO.FolderExists(Nz(Me.txt_folderpath, "")) Then
Set mFolder = myFSO.GetFolder(Me.txt_folderpath)
For Each MyFile In mFolder.Files
If (myFSO.GetExtensionName(MyFile.Name) = "xlsx") Then 'Or (myFSO.GetExtensionName(MyFile.Name) = "xls")
Me.lbx_show.AddItem MyFile.Path
' Debug.Print MyFile
End If
Next MyFile
' Checks if there are excel spreadsheets in the folder
If Dir(Me.txt_folderpath & "*.xlsx") = "" Then
Beep
MsgBox "No Excel Spreadsheet Found!"
End If
Else
Beep
MsgBox "Folder Does Not Exist"
End If
End Sub
I guess you want to add for each directory you choose in the textbox the files to the listbox and if you run the code in your post a second time it should not add the same file a second time. You can do that by using a dictionary and adding the filenames to the dictionary
Option Compare Database
Option Explicit
' Dictionary for the filenames
Dim dict As New Scripting.Dictionary
Public Sub btn_folderimp_Click()
' Displays Excel SpreadSheets In Selected Folder
Dim myFSO As New FileSystemObject
Dim MyFile As File
Dim mFolder As Folder
' Dim lbx As ListBox
'Checks If No Folder Was Selected
If Nz(Me.txt_folderpath, "") = "" Then
Beep
MsgBox "No Folder Selected!"
Exit Sub
End If
' clear the listbox
lbx_show.RowSource = ""
'Checks If Folder Exists, If Yes, it displays a list of spreadsheets in the Folder
If myFSO.FolderExists(Nz(Me.txt_folderpath, "")) Then
Set mFolder = myFSO.GetFolder(Me.txt_folderpath)
For Each MyFile In mFolder.Files
If (myFSO.GetExtensionName(MyFile.Name) = "xlsx") Then 'Or (myFSO.GetExtensionName(MyFile.Name) = "xls")
' will add a new entry if it not exists
dict(MyFile.Path) = MyFile.Path
'Me.lbx_show.AddItem MyFile.Path
End If
Next MyFile
' add the filenames to the listbox
Dim key As Variant
For Each key In dict.Keys
Me.lbx_show.AddItem key
Next
' Checks if there are excel spreadsheets in the folder
If Dir(Me.txt_folderpath & "*.xlsx") = "" Then
Beep
MsgBox "No Excel Spreadsheet Found!"
End If
Else
Beep
MsgBox "Folder Does Not Exist"
End If
End Sub
I have a folder with many different files and I want to insert a column with the name of the file.
This is my code:
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
Sheets(1).Range("j1").Value = "Date"
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
So what I want to do is add some part of the file name to the entire J column except the header that is "Date" which I already implemented in the code above.
Thanks in advance
Add this code just after your "Date" value setting and before you close and save changes:
Dim i As Long
For i = 2 To Sheets(1).UsedRange.Rows.Count
Sheets(1).Range("J" & i).Value = MyFile
Next i
This will insert the whole filename to the J column for each row, except for the header (2), that has data in the sheet. You should now be able to adapt this code for "some part of the filename" (you don't say which part!).
Write a code in vba that, Calling user form of one excel file to all the other 10 excel files without having any reference in those 10 excel files.
It is displaying the output in current excel file but not in the destination files and shows the error as Userform is already shown and showing form modally is not possible
Private Sub Workbook_OnClick()
Dim mypath As String
Dim file As Workbook
Dim wb As Workbook
Dim pat As String
Application.ScreenUpdating = False
ChDrive "C:"
ChDir "C:\Users\Administrator\Desktop\John"
'john is a folder on the desktop
mypath = Range("B1").Value
'mypath has the same value as chDir
file = Dir(mypath & "\" & "*.xlsx")
Set wb = Application.Workbooks.Open(file)
If (wb.Click) Then
Application.Visible = False
userform1.Show
End If
End Sub
chDir is mentioned because the default directory shown with the dir() function was C:\Users\Administrator\Documents\ but the folder saved in desktop and that is C:\Users\Administrators\Desktop\John
Sir, It is displaying the run time error - 91 that is "Object variable or with block variable is not set" and highlighting the line "file = Dir(mypath & "\" & "*.xlsx")"
Private Sub Workbook_OnClick()
Dim mypath As String
Dim file As String
Dim wb As Workbook
Dim pat As String
Application.ScreenUpdating = False
ChDrive "C:"
ChDir "C:\Users\Administrator\Desktop\John"
'john is a folder on the desktop
mypath = Range("B1").Value
'mypath has the same value as chDir
file = Dir(mypath & "\" & "*.xlsx")
Do While file <> ""
Set wb = Application.Workbooks.Open(file)
If Not IsEmpty(wb) Then
Application.Visible = False
userform1.Show
End If
wb.Close
file = Dir()
Loop
End Sub
I am running the following VBA in Ecel to open a folder and then update all Excel sheets within this folder. However I would like it to include all subfolders as well.
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> “”
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
Ok, you'll need to use the FileSystemObject and add a reference to the Windows Script Host Object Model in Tools->References. Then try the code below.
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
Dim FSO As New FileSystemObject ' Requires "Windows Script Host Object Model" in Tools -> References
Dim ParentFolder As Object, ChildFolder As Object
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders
MyFile = Dir(MyFolder & ChildFolder.Name) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & ChildFolder.Name & "\" & MyFile)
'Replace the line below with the statements you would want your macro to perform
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:05"))
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Next ChildFolder
Application.ScreenUpdating = True
End Sub
Or, you can just use CMD and read the output, much faster for drilling down through subfolders.
I've used ".xl*" as the file filter (I assume you only want Excel files?) but change this as you see fit:
Sub MM()
Const startFolder As String = "C:\Users\MacroMan\Folders\" '// note trailing '\'
Dim file As Variant, wb As Excel.Workbook
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & startFolder & "*.xl*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
Set wb = Workbooks.Open(file)
'// Do what you want here with the workbook
wb.Close SaveChanges:=True '// or false...
Set wb = Nothing
Next
End Sub
I have a VB form in Access 2010, that opens a file dialog box to make a excel selection. I send the file path as string to my variable: directory (directory = strPath) to open the workbook and copy its contents to my current workbook. Which works fine if you intend to use the tool once. It's when you import one file, then another that's in the same directory the error occurs.
Non-working Example:
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\File2.xls, Import
Error:
Run-time error '1004':
A document with the name 'Tool.xlsm' is already open. You cannot open two documents with the same name, even if the documents are in different folders. To open the second document, either close the document that's currently open, or rename one of the documents.
Working Example (Separate Folders):
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\TestFolder\File2.xls, Import
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Dim strPath As String
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = strPath
FileName = Dir(directory & "*.xls")
Do While FileName <> ""
Workbooks.Open (directory & FileName)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("Tool.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("Tool.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub
In DEBUG mode it doesn't like
Workbooks.Open (directory & FileName)
Any suggestions on a way to eliminate this error?
First, between directory and FileName, i assume there is a "\".
secondly, simply check if the workbook is already opened:
dim wb as workbook
err.clear
on error resume next
set wb = Workbooks (FileName) 'assuming the "\" is not in FileName
if err<>0 or Wb is nothing then 'either one works , you dont need to test both
err.clear
set wb= Workbooks.Open (directory & FileName)
end if
on error goto 0
if you don't use application.enableevents=false, your opened Wb will trigger its workbook_open events !
I wanted to post the working code, maybe it will help someone in the future. Thanks again to those who left comments.
This code will open a file dialog, allow the user to select 1 excel file then copy all sheets from the selected file into the current workbook.
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to textbox1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Dim wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Err.Clear
On Error Resume Next
Set wb = Workbooks(FileName) 'assuming the "\" is not in FileName
If Err <> 0 Or wb Is Nothing Then 'either one works , you dont need to test both
Err.Clear
Set wb = Workbooks.Open(directory & TextBox1)
End If
On Error GoTo 0
FileName = Dir(directory & TextBox1)
Do While FileName <> ""
Workbooks.Open (directory & TextBox1)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub