I want to write a macro that will open 30 excel files which all have the same structure.
The macro should do operation on all files, and take the results from every file and put it in another excel file.That means: all Results (Values) will be copied into the destination file.
How do I write VBA code to open multiple files?
How do I take the results from every file and place them in my destination.xls file?
Try checking out FileSearch.LookIn Property
modify that example to something similar. (This would require that all your 30 files are in one folder though)
Dim WrkBook as Workbook
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False
.LookIn = "C:\My Documents" 'Path of folder to search
.FileName = "*.xls" 'Limit to excel files
If .Execute > 0 Then
Debug.Print "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
WrkBook = Workbooks.Open(Filename:=.FoundFiles(i))
WrkBook.Worksheets(1).Select
ThisWorkbook.Worksheets(1).Cells(DestinationRange) = WrkBook.Worksheets(1).Cells(SourceRange).Value
Next i
Else
Debug.print "There were no files found."
End If
End With
You could also try
Workbooks("Destination.xls").Worksheets("Sheet1").Cells(DestinationRange) = WrkBook.Worksheets(1).Cells(SourceRange).Value
I think you're after a solution, that requires the user to choose the files to open and process?
Try this...
Option Explicit
Sub opening_multiple_file()
Dim i As Integer
'Opening File dialog box
With Application.FileDialog(msoFileDialogFilePicker)
'Enabling multiple files select
.AllowMultiSelect = True
.Filters.Clear
'Only Excel files can be selected
.Filters.Add "Excel Files", "*.xls*"
If .Show = True Then
For i = 1 To .SelectedItems.Count
'Opening selected file
Workbooks.Open .SelectedItems(i)
'etc do other things with it
Next i
End If
End With
End Sub
Related
I have a lot of files in one folder. What I want to do is add a column with the name of the file. I found a solution to this, but I want to optimize. Currently I am just adding the values from J2 to J1000 to make sure I cover all rows. This is not ideal as the amount of rows in each file differ. What I want to do is find a way to add the value matching the amount of rows that exists in the sheet.
I want to find a way to check if there is data in column A for each row and then add the value as long as there is some data in column A for each row.
My thoughts would be to do a while statement to check if each row in column A is different from an empty string and add the value as long as it is different from an empty string. However I am not sure how to implement this.
Here 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"
Sheets(1).Range("j2:j1000").Value = Mid(ActiveWorkbook.Name, 10, 10)
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
I use the following to open a dialog box to select files.
fnameListCurr = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv),*.csv", Title:="Choose CSV files to import", MultiSelect:=True)
However, when I do this, nothing is selected by default. Is it possible to have the file selector dialog open with certain files or all files that meet the filter criteria already selected?
If you need to set an initial Fine name, use FileDialog instead. Try the next code, please:
Sub filedialogSelectSomething()
Dim fileName
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Choose CSV files to import"
.InitialFileName = "Your Path\Test*.csv"
.Filters.Add "CSV Files", "*.csv", 1
If .Show = -1 Then
fileName = .SelectedItems(1)
'or use them all...
End If
End With
Debug.Print fileName
End Sub
Look here to better understand how InitialFileName overrides the file filter settings...
I'm looking to open multiple Excel files and run the same macro (contained in each) on each file.
For example, I'd like to automatically open every file in h:\dbs and execute the CmdUpdate_Click macro within each file.
How might I go about this?
Try something like this. I expect you can research how to open the Visual Basic Editor and figure out where to paste this.
'Declare variables
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "B:\BIM Projects\"
.InitialView = msoFileDialogViewDetails
'Check if user canceled dialog box
'Exit if yes
If .Show = -1 Then
MsgBox "No Folder Selected"
Exit Sub
End If
End With
'Check if user canceled dialog box
'Exit if yes
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
'For each obj in the selected folder
For Each FileObj In FolderObj.Files
'Test if the file extension contains "xl" and make sure it's an Excel file before opening
If InStr(1, Right(FileObj.Name, Len(FileObj.Name) - InStr(1, FileObj.Name, ".")), "xl") = 1 Then
'Prevent the workbook from displaying
ActiveWindow.Visible = False
'Open the Workbook
Workbooks.Open (FolderObj & "\" & FileObj.Name)
'Run the Macro
Application.Run "'" & FolderObj & "\" & FileObj.Name & "'!CmdUpdate_Click"
'Save the Workbook
Workbooks(FileObj.Name).Save
'Close the Workbook
Workbooks(FileObj.Name.Close
End If
'Turn this back on
ActiveWindow.Visible = True
Next
I will caution you that this is based on some code I wrote for Word, so there are no guarantees it will work and I don't have time to test it. It will, however, give you a very good start if it doesn't.
Edit to Add: You may
Hi i am looking dynamic path to be taken for uploading excel file and should ask where to save the file. here is my code.`where as i tried but it is taking only static path. Any help would be appreciated.
'To Combine Sheets
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'This line will need to be modified depending on location of source folder
FolderLocation = "U:\ECA" 'file location need to be dynamic
'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation
'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal) 'file name should be specified by user input and output file
'Iterate for each file in folder
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set WorkbookSource = Workbooks.Open(Filename:=FolderLocation & "\" & strFilename)
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
strFilename = Dir()
Loop
WorkbookDestination.Worksheets(1).Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=FolderLocation
Application.DisplayAlerts = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True`
This block of code is good once everything is running properly: Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = FalseUntil your code is completely debugged, though, it will make your life a nightmare. Comment those 3 out until this procedure is running the way you want it.
you appear to declare (Dim) some of your variables, but not all. I would strongly recommend adding Option Explicit to the top of all your code modules to force variable declaration prior to use - it helps prevent typos in variable names from messing things up down the road.
You assign SelectedFiles the return value from Application.GetOpenFilename, but don't ever use it. When it's assigned, you will have an array of file names that the user selected, and they will include the full path. This may provide the path information you need (the dialog box will allow the user to navigate to the desired folder), but I'm not sure, because...
You assign strFilename = Dir(FolderLocation & "\*.xls", vbNormal) which gives you the first *.xls file located in FolderLocation. You then loop through all the *.xls files there.
I would suggest that using your existing code, you could pull the path information from SelectedFiles like this:
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=False)
If InStrRev(SelectedFiles, "\") > 0 Then
FolderLocation = Left(SelectedFiles, InStrRev(SelectedFiles, "\"))
End If
Note that I changed Multiselect:=False to allow the user to only select one file - I don't see where you're using this variable anywhere else, so I've modified it to simply use it as a path picker. If that's incorrect, you'll have to make another modification to select the path. Otherwise, FolderLocation will now point to the directory that the user selected and you can continue your looping after that using the folder they selected.
MY GOAL: Batch convert all .TDM files in a folder to .XLS using an existing add-in by adapting this macro that only works 1 file at a time. (Also open to any VBA approach.)
Using an existing add-in, a single .TDM file is converted into a single .XLS workbook with multiple sheets.
I need to, instead of using a prompt to select a single .TDM file, automatically convert all .TDM files in a folder into new .XLS workbooks.
This is part of a multi-stage process. I tried various loops, mimicking other set-ups, and merging it with other code I found on various community boards.
FYI: .TDM files hold engineering data output produced by testing equipment.
Sub GetTDM_AddIn()
'Get TDM Excel Add-In
Dim obj As COMAddIn
Set obj = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
'obj.Connect = True
'Confirm only importing "Description" properties for Root
Call obj.Object.Config.RootProperties.DeselectAll
Call obj.Object.Config.RootProperties.Select("Description")
'Show the group count as property
Call obj.Object.Config.RootProperties.Select("Groups")
'Select all the available properties for Group
Call obj.Object.Config.GroupProperties.SelectAll
'Import custom properties
obj.Object.Config.RootProperties.SelectCustomProperties = True
obj.Object.Config.GroupProperties.SelectCustomProperties = True
obj.Object.Config.ChannelProperties.SelectCustomProperties = True
'Let the user choose which file to import
Dim fileName
fileName = Application.GetOpenFilename("TDM & TDMS (*.tdm;*.tdms),*.tdm;*.tdms")
If fileName = False Then
' User selected Cancel
Exit Sub
End If
'Import the selected file
Call obj.Object.ImportFile(fileName)
'Record down the current workbook
Dim Workbook As Object
Set Workbook = ActiveWorkbook
End Sub
Below is an Excel Macro (VBA Script) I wrote to do something very similar to what you want to do. It converts a directory of .tdms files to their equivalent .csv files. It requires the ExcelTDM Add In (NITDMEXCEL_2015-0-0.exe) which I obtained at http://www.ni.com/example/27944/en/. I tested the script in Excel 2013 running on a modest Windows 7 Pro machine converting 24 TDMS files with 120,000 rows each file. It completed the conversions without error in about 2 minutes 30 seconds which is about 7 seconds per file. Please forgive my hasty error handling and poor VBA form.
Sub ConvertTDMStoCSV()
'
' ConvertTDMS Macro
'
' Acts upon all .tdms files in a "source" directory,
' loading each one using the ExcelTDM Add In,
' deleting the first sheet and saving the
' remaining stream data as one .csv file
' in a "target" directory. Writes a list of
' the files converted in a new sheet.
'
' Tested to work with Excel 2013 on Windows 7
' with NITDMEXCEL_2015-0-0.exe obtained at
' http://www.ni.com/example/27944/en/
Dim sourceDir As String, targetDir As String, fn As String, fnBase As String
Dim fso As Object, n As Long, resp As Integer, strNow As String, newSheet As Object
Dim tdmsAddIn As COMAddIn, importedWorkbook As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set tdmsAddIn = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
tdmsAddIn.Connect = True
Call tdmsAddIn.Object.Config.RootProperties.DeselectAll
Call tdmsAddIn.Object.Config.ChannelProperties.DeselectAll
tdmsAddIn.Object.Config.RootProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.GroupProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.ChannelProperties.SelectCustomProperties = False
'Choose TDMS Source Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Source Directory of TDMS Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
sourceDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(sourceDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, sourceDir
Exit Sub
End If
'Choose CSV Target Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Target Directory for CSV Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
targetDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(targetDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, targetDir
Exit Sub
End If
fn = Dir(sourceDir & "\*.tdms")
If fn = "" Then
MsgBox "No source TDMS files found.", vbInformation
Exit Sub
End If
resp = MsgBox("Begin conversion of TDMS files?" & vbCrLf & sourceDir & vbCrLf & "to" & vbCrLf & targetDir, vbYesNo, "Confirmation")
If resp = vbNo Then
MsgBox "Execution cancelled by user."
Exit Sub
End If
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
strNow = WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss")
newSheet.Name = strNow
newSheet.Cells(1, 1).Value = "Files converted on " & strNow
newSheet.Cells(2, 1).Value = "TDMS Source Directory: " & sourceDir
newSheet.Cells(3, 1).Value = "CSV Target Directory: " & targetDir
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 5
Do While fn <> ""
fnBase = fso.GetBaseName(fn)
On Error Resume Next
Call tdmsAddIn.Object.ImportFile(sourceDir & "\" & fn, True)
If Err Then
MsgBox Err.Description, vbCritical
Exit Sub
End If
Set importedWorkbook = ActiveWorkbook
Application.DisplayAlerts = False
importedWorkbook.Sheets(1).Delete
importedWorkbook.SaveAs Filename:=targetDir & "\" & fnBase & ".csv", FileFormat:=xlCSV
importedWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
newSheet.Cells(n, 1).Value = fnBase
n = n + 1
fn = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
Set newSheet = Nothing
Set importedWorkbook = Nothing
End Sub
Instead of trying to do this in VBA, I suggest that you use powershell to get all of the files and then call the Excel macro, for each file, using the Run method.
You'll also need to modify the macro to either (1) run on the current open file (solution below); or (2) take a filename as an argument (this changes the call to Run below)
The code is something like this (modify the call to get-childitem to fit your applicaton):
$excel = new-object -comobject excel.application
$files = get-childitem ... #etc, collect your files into an array
foreach ($file in $files)
{
$wb = $excel.workbooks.open($file.fullname)
$ws= $wb.worksheets.item(1)
$ws.Activate()
$excel.Run("GetTDM_AddIn")
$wb.save()
$wb.close()
}
$excel.quit()
I used this simple app to convert tdms files.
It supports multiple files and has command line support.
http://www.whiterocksoftware.com/2019/11/batch-convert-tdms-to-excel.html