Instead of providing the file path in my code, I prompt the user to select the folder that contains data files in xlsx format, over which is looped via: For Each wbFile In fldr.Files.
I am getting error 424.
See the commented out lines in the code:
Sub getDataFromWbs()
Dim wb As Workbook, ws As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")
'Set fldr = fso.GetFolder("\\name_of_folder_to_get_files_from\") 'old code
'Dim FolderName As String 'fldr was previously, original code: FolderName
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
fldr = .SelectedItems(1) 'fldr was previously, original code: FolderName
Err.Clear
On Error GoTo 0
End With
i = "1" 'set integer for loop over sheets
For Each wbFile In fldr.Files 'loop over data in prompted folder
Here's a quick fix of your code:
Sub getDataFromWbs()
Dim wb As Workbook, ws As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")
'Set fldr = fso.GetFolder("\\name_of_folder_to_get_files_from\") 'old code
'Dim FolderName As String 'fldr was previously, original code: FolderName
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1) 'fldr was previously, original code: FolderName
Err.Clear
On Error GoTo 0
End With
i = "1" 'set integer for loop over sheets
Set fldr = fso.GetFolder(FolderName)
For Each wbFile In fldr.Files 'loop over data in prompted folder
Related
I am a VBA noob and I am working on a script that would capture the header and footer settings of all word files in a folder. I would like to create an array, and save the values for header and footer for each file that can be found on the folder. I think I have managed to create the loop, however, I do not know how to save these values to an array.
Here is a sample of my script:
Option Explicit
Public savepath As String
'This will select the file/folder
Public Sub select_folder()
Dim Filepicker As FileDialog
Dim mypath As String
Set Filepicker = Application.FileDialog(msoFileDialogFolderPicker)
With Filepicker
.Title = "Select folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Select(&S)"
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
End
End If
End With
NextCode:
'select_folder = mypath
Set Filepicker = Nothing
savepath = mypath
End Sub
Sub excel_report()
Dim strFile As String
Dim strInFold As String
Dim extension As String
Dim WrdSrc As Word.document
Dim WrdApp As Word.Application
'count the files in the folder
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
counter = counter + 1
strFile = Dir
Loop
Dim arry(counter, 3) As Variant
'save values of files into an array
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
'open word application
On Error Resume Next
' Check whether Word is running
Set WrdApp = GetObject(, "Word.Application")
If WrdApp Is Nothing Then
' Word is not running, create new instance
Set WrdApp = CreateObject("Word.Application")
' For automation to work, Word must be visible
WrdApp.Visible = True
End If
On Error GoTo 0
DoEvents
' open file
Set WrdSrc = WrdApp.Documents.Open(filename:=strInFold & strFile)
'Add Array (arry) Values here
'assign strfile (file name) on column 1
'WrdSrc.Sections(1).Headers(wdHeaderFooterPrimary).Range on column 2
'WrdSrc.Sections(1).Footers(wdHeaderFooterPrimary).Range on column 3
'move to next row
Loop
End Sub
I am trying to achive an output that looks like this:
FileName HeaderValue FooterValue
testfile.doc ABCD Company Confidential Information
Testfile2.doc CDEF Company All rights reserved to CDEF company
And I would like to add this array to a new sheet, then add this sheet to the current workbook where this vba script is running.
How do we go about doing this?
Thank you in advance!
I have a macro excel file that does some clean up on cells and I need to import a single sheet from various files on the same folder. For example I need the sheet1 from all the excel files located on the same folder as my macro file. I have a code to do that manually but I need to be able to do it automatically either by selecting the files or running another macro to select them no matter the amount of files on the folder.
Sub Carga_Masiva()
Dim fName As String, wb As Workbook
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
I'd prompt user for a folder and then iterate over each file except the one with your macro.
To prompt for a folder use this solution (in my code as optional variant): link
Complete code below:
Sub Carga_Masiva()
Dim sh As Worksheet
Dim fName As String, wb As Workbook
fName = Application.GetOpenfnamename("Excel fnames (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
Sub CopyToThisWorkbook()
Dim wbMacro, wb As Workbook
Set wbMacro = ThisWorkbook
Dim sh As Worksheet
Dim folderPath, fName, tabName As String
folderPath = wbMacro.Path & Application.PathSeparator
'Prompt variant
'folderPath = GetFolder & Application.PathSeparator
fName = Dir(PathName:=folderPath)
Do
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open all files except the one with macro
If fName <> wbMacro.Name Then
'Your code
Set wb = Workbooks.Open(wbMacro.Path & "\" & fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
tabName = sh.Name & "_" & Right(wb.Name, 10) 'Optional - rename Worksheet to be copied
sh.Name = tabName 'Optional
sh.Copy Before:=wbMacro.Sheets(1)
Exit For
End If
Next sh
wb.Close SaveChanges:=False
End If
fName = Dir
Loop Until fName = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolder() As String 'Optional variant
Dim fldr As fnameDialog
Dim sItem As String
Set fldr = Application.fnameDialog(msofnameDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialfnameName = Application.DefaultfnamePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I'm trying to set the default directory for the VBA function GetOpenfilename. I managed to get it working before but lost the code before saving it.
Sub Sample2()
Dim myFile As Variant
Dim i As Integer
Dim myApp As Excel.Application
Dim strCurDir As String
Set myApp = New Excel.Application
ChDrive ("H:\")
ChDir ("H:\99 - Temp")
'Open File to search
myFile = myApp.GetOpenFileName(MultiSelect:=True)
If myFile <> False Then
If IsArray(myFile) Then '<~~ If user selects multiple file
For i = LBound(myFile) To UBound(myFile)
Debug.Print myFile(i)
Next i
Else '<~~ If user selects single file
Debug.Print myFile
End If
Else
Exit Sub
End If
End Sub
I tried several variations of this code and the posts I found are very old. It is going to be part of a bigger code in Outlook 2016.
Try the FileDialog property of the Excel object instead...
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim myFile As Variant
With xlApp.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.ButtonName = "Select"
.Title = "Select File"
.InitialFileName = "H:\99 - Temp\"
If .Show = 0 Then Exit Sub 'user cancelled
For Each myFile In .SelectedItems
Debug.Print myFile
Next myFile
End With
Set xlApp = Nothing
I have a VBA macro that open files in a folder, download data from an add-in, save and close.
This runs fine, but after 10 or 15 files, it gets quite slow. I think it is because Excel still keep previously opened files in the memory. I knew this because I saw the already-opened-and-closed files on the left panel as in the photo below. (the photo is to show where the panel is, I know there is only one file opened with the sheets, but you know what I mean).
My question is: is there a line of code that refresh or clear this temporary memory?
Here is my code:
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Application.ScreenUpdating = False
StartTime = Timer
'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
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = Workbooks.Open(filename:=myPath & myFile)
Set cmd = Application.CommandBars("Cell").Controls("Refresh All")
cmd.Execute
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
What about add:
set cmd = nothing
before
wb.Close savechanges:=True
There is a known issue in Excel with closed Workbooks leaving data in Memory, which can only be cleared by closing and reopening Excel.
The below code uses a late-bound second instance of the Excel application, in an attempt to alleviate this issue; the second instance will be closed and reopened periodically (currently set to every 5 files).
Sub SomeName()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
'NEW CODE
Dim appXL AS Object, counterFiles AS Long
counterFiles = 0
Application.ScreenUpdating = False
StartTime = Timer
'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
If myPath = "" Then GoTo ResetSettings
'Assign the folder to oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(myPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then GoTo ResetSettings
For Each oFile In oFolder.Files
'NEW CODE
If appXL Is Nothing Then Set appNewExcel = CreateObject("Excel.Application")
DoEvents
'Set variable equal to opened workbook
myFile = oFile.Name
Set wb = appNewExcel.Workbooks.Open(filename:=myPath & myFile)
'Update / Refresh workbook
wb.RefreshAll
appNewExcel.CalculateFullRebuild
DoEvents
'Ensure Workbook has opened before moving on to next line of code
wb.Save
DoEvents
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
'NEW CODE
Set wb = Nothing
counterFiles = counterFiles+1
If counterFiles mod 5 = 0 Then
appNewExcel.Quit
Set appNewExcel = Nothing
End If
DoEvents
Next 'oFile
SecondsElapsed = Timer - StartTime
MsgBox "This code ran successfully in " & SecondsElapsed
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
End Sub
I am trying to set up an excel sheet with a list of folders in a main folder (not including sub folders within the folders). I've succeeded in running a VBA to create the list and then I have used the list to add on the different information needed for each folder (see image of visual setup).
But I would like to be able to update the list, so whenever new folders are added to the main folder it will appear on the list in the sheet.
Is it possible to update the list to the format I have created either by macro, or button or automatically ?
Option Explicit
Sub ListFoldersInDirectory()
Dim objFSO As Object
Dim objFolders As Object
Dim objFolder As Object
Dim strDirectory As String
Dim arrFolders() As String
Dim FolderCount As Long
Dim FolderIndex As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select Folder"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
strDirectory = .SelectedItems(1)
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
FolderCount = objFolders.Count
If FolderCount > 0 Then
ReDim arrFolders(1 To FolderCount)
FolderIndex = 0
For Each objFolder In objFolders
FolderIndex = FolderIndex + 1
arrFolders(FolderIndex) = objFolder.Name
Next objFolder
Worksheets.Add
Range("A1").Resize(FolderCount).Value = Application.Transpose(arrFolders)
Else
MsgBox "No folders found!", vbExclamation
End If
Set objFSO = Nothing
Set objFolders = Nothing
Set objFolder = Nothing
End Sub