I have a VBA macro with about 20 modules, which create separate spreadsheets in the workbook. They also save the individual spreadsheet created by each module of the macro into a specific folder on a shared drive.
This is an example of a couple of lines that save the spreadsheet to the separate folder.
z = Format(DateTime.Now, "dd-MM-YYYY hhmm")
wb.SaveAs "J:\AAAA\BBBB\CCCC\DDDD\mod1" & z & ".xlsx"
Workbooks("mod1" & z & ".xlsx").Close savechanges:=True
However, as this file is now being shared out among a number of users, with different functions, the users now want to be able to set the location where the spreadsheets generated will be saved, on an individual basis.
What I am looking for is some way for the macro to open a new window, and for the user to select a file path. That file path would then be stored into the macro so that each module can read the file location where it needs to be stored.
Is this possible?
Edit 1:
I should have made a couple of things clearer. My apologies.
The code above is replicated in every module. Also, all the modules are run from one overarching module, that calls the other.
What I am looking for is a code that will allow the user to select the save location at the start of the overarching module. Eg. J\AAA\CCC\XXX. The modules, when called, will to retrieve the file path, and then save the file to that location.
use this function:
Function GetFolder() 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
it returns a folderpath
If you want to have them select a file name, you can use this function. It prompts the user for a folder location and file name. The function returns an absolute file path. It returns vbNullString if the user cancelled the dialog.
Public Function SaveWorkbook() As String
Dim fileName As Variant
fileName = Application.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xlsx), *.xlsx")
If fileName <> False Then Exit SaveWorkbook = fileName
End Sub
Related
I'm attempting to put together some code in VBA where it will open a specific folder, let me choose the file then continue running my code.
Currently what I have (below) "works" in that it will open a folder but usually it starts from a generic location (Desktop) but will not go the the specific folder location to let me open the file I want.
Dim Filename as String
filename = Application.GetOpenFilename(FileFilter:="Excel Files, *.xl*;*.xm*")
If filename <> False Then
Workbooks.Open filename:=filename
End If
I've also tried something like this:
Dim Directory as String
Dim Filename as String
Directory = "\\page\data\NFInventory\groups\CID\Retail Setting\Lago Retail Uploads\" & strBrand & "\" & strSeason & "\" & strPrefix & "\"
Filename = Dir(Directory & "*.xl*;*.xm*")
Workbooks.Open Filename:=Directory
But it doesn't do anything and I think I have everything right. Any help or push in the right direction would be greatly appreciated.
-Deke
This will start an Open Dialog at the specified location:
Sub openBeckJFolder()
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
.InitialFileName = "C:\Users\beckj\"
End With
End Sub
The Microsoft document page doesn't really get into it, but FileDialog has several features such as the InitialFileName that I used here.
_
UPDATE: To open the workbook
Code added that allows you to highlight the workbook & click Open, or double-click on the workbook to open it.
Sub openBeckJFolder()
Dim Filename As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = "C:\Users\beckj\"
If .Show = True Then
Filename = .SelectedItems(1)
End If
End With
Workbooks.Open (Filename)
End Sub
I've got a folder which contains .txt files (they contain PHI, so I can't upload the .txt file, or an example without PHI, or even any images of it). I need an excel macro, which will allow the user to choose the folder containing the file, and will then insert the .txt file data into a new excel workbook, format the rows and columns appropriately, and finally save the file to the same folder that the source was found in.
So far I've got all of that working except for the formatting of rows and columns. As of now, the .txt data is inserted to a new workbook & worksheet, but I can't seem to figure out how to get rid of rows I don't need, or how to get the columns formatted appropriately.
Again, I can't upload the .txt file (or anything) because the Healthcare organization I work for blocks it - even if I've removed all PHI.
Below is the macro I've created so far:
Private Sub CommandButton2_Click()
On Error GoTo err
'Allow the user to choose the FOLDER where the TEXT file(s) are located
'The resulting EXCEL file will be saved in the same location
Dim FldrPath As String
Dim fldr As FileDialog
Dim fldrChosen As Integer
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder containing the Text File(s)"
.AllowMultiSelect = False
.InitialFileName = "\\FILELOCATION"
fldrChosen = .Show
If fldrChosen <> -1 Then
MsgBox "You Chose to Cancel"
Else
FldrPath = .SelectedItems(1)
End If
End With
If FldrPath <> "" Then
'Make a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add
'Make worksheet1 of new workbook active
newWorkbook.Worksheets(1).Activate
'Completed files are saved in the chosen source file folder
Dim CurrentFile As String: CurrentFile = Dir(FldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
'How many rows to place in Excel ABOVE the data we are inserting
LineIndex = 0
Close #1
Open FldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
'Adds number of rows below the inserted row of data
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
.TextToColumns Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Name = Replace(CurrentFile, ".txt", "")
ActiveWorkbook.SaveAs FldrPath & "\" & Replace(CurrentFile, ".txt", ".xls"), xlNormal
ActiveWorkbook.Close
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Done:
Exit Sub
err:
MsgBox "The following ERROR Occurred:" & vbNewLine & err.Description
ActiveWorkbook.Close
End Sub
Any ideas of how I can delete entire lines from being brought into excel?
And how I can format the columns appropriately? So that I'm not getting 3 columns from the .txt file all jammed into 1 column in the resulting excel file?
Thanks
I'd recommend you not to re-invent the wheel. Microsoft provides an excellent add-on to accomplish this task, Power Query.
It lets you to load every file in a folder and process it in bulks.
Here you have a brief introduction of what can do for you.
We work off multiple reports that all start with the name of the report and end with the date in the same format every time, such as 'Example Report 28.09.16.xls'.
I am trying to show results from one workbook in another workbook when they are both open at the same time, is there anyway to make this work using left function or contains so that I can open any combination of 2 reports and they will pull over irrelevant of the date?
Windows("Example Report 28.09.16.xls").Activate
Or
=VLOOKUP(B1,'[Example Report 28.09.16.xls]Sheet1'!$B$1:$C$10,2,FALSE)
I would prefer this to be a macro but a formula version would be good also.
As above I need the date to be able to be anything else, as the person opening the report will open the relevant report at the same time.
The goal is to have an item that is referenced in a number of reports show all the data for each report next to that item in one report.
Does anyone know of how I can do this or any better way around this?
EDIT
Another idea ive just had, is there a way to piece together the window to activate by using the 'Right' function to pull the date from the filename of the current file open then add it to the static report name I am referencing? such as:
Dim ReportDate As String
ReportDate = Right(ThisWorkbook.FullName,12)
Dim ReportName As String
ReportName = "Example Report "
Windows( ReportName + ReportName ).Activate
You could ask the user to select the files to open, or use some way of getting a valid date (maybe a calendar control) and then use the references to those workbooks in the code.
The code below will ask for the location of the file (using the GetFile1 function) and open that. It will then open the file with todays date on the users desktop (GetFile) - just pass a different date for a different file.
It will then grab the value from cell A1 in the two workbooks and place those values in cells A1:A2 of the workbook containing the code.
Public Sub Test()
Dim wrkBk1 As Workbook
Dim wrkBk2 As Workbook
Set wrkBk1 = Workbooks.Open(GetFile1)
Set wrkBk2 = Workbooks.Open(GetFile(Date))
'ThisWorkbook is the file containing this code.
With ThisWorkbook.Worksheets("Sheet1")
.Cells(1, 1) = wrkBk1.Worksheets("Sheet1").Cells(1, 1) 'Get the value from A1 and place in A1.
.Cells(2, 1) = wrkBk2.Worksheets("Sheet1").Cells(1, 1) 'Get the value from A1 and place in A2.
End With
End Sub
Function GetFile1(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xls*", 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
Function GetFile(dDate As Date) As Variant
GetFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Example Report " & Format(dDate, "dd.mm.yyyy") & ".xls"
End Function
I am looking to convert the code below to one where user is not required to select the files .
This code is to select a specific sheet from all the workbooks in the specific folder say" C:\Test"
This is a part of a consolidation macro
sub open_issues_sheet()
Dim Files as Variant
Files = Application.GetopenFilename("Excel FIles (*xl*),*xl*",Title:="Select Files", Multiselect:=True)
For Z = LBound(Files) To UBound(Files)
tem=Split(Files(Z),"\")
If(tem(UBound(tem)) <> ThisWorbook.Name) Then
Set S= Workbooks.Open(Files(Z))
S.Sheets("Issues").Select
'code to copy to current sheet
I tried using this http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/
but I was getting a "Type Mismatch" Error at the Line "For Z =LBound"
Assuming that you still need the user to pick the folder containing the files that need to be consolidated, using the FileDialog(msoFileDialogFolderPicker) would be acceptable solution.
Dim sFilePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select folder to consolidate"
If .Show = -1 Then
'Get the first file listed in the folder
sFilePath = Dir(.SelectedItems(1) & "\")
Do While Not sFilePath Like vbNullString
'Verify the extension before opening file
If Mid$(sFilePath, InStrRev(sFilePath, ".")) Like ".xls" Then
' Perform task ...
End If
'Get next file
sFilePath = Dir
Loop
End If
End With
My goal is to write a VBA macros that will allow:
to choose a folder with files to open
then to count number of rows in each file (each file contain only 1 sheet).
to move to another folder all the files that contain more than 1 row
I'm very new in VBA, so what i found is how to count number of rows from active worksheet, but i still can't manage automatically files opening and moving to another folder:
Sub RowCount()
Dim iAreaCount As Integer
Dim i As Integer
Worksheets("Sheet1").Activate
iAreaCount = Selection.Areas.Count
If iAreaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.Count & " rows."
Else
For i = 1 To iAreaCount
MsgBox "Area " & i & " of the selection contains " & _
Selection.Areas(i).Rows.Count & " rows."
Next i
End If
End Sub
Could someone help with this, please?
This is actually easy. Really easy. :)
First, code to choose a folder to look into for Excel files. Used Google and searched for excel vba select folder dialog. First result yields this code:
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
We'll get to using it for later. Next, we need a loop to count how many rows there are in each file/sheet. However, we can't count them without these files open. So, let's look for a code that opens workbooks in a loop. Googling excel vba open excel files in folder, we get the second result. First result is a deprecated method in Excel 2007 and up. I will be assuming you're running 2007 and up. Here's the code, applying the proper correction detailed by Siddharth Rout.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = "Blah blah blah"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Now, some semi-advanced best practices. Rather than opening each workbook/worksheet/file and counting the rows in each of the opened files (which is highly counter-intuitive), let's modify the above code to count the rows in each file as well, then move them to another folder if they have more than one (1) used row. We'll also change the above code to take into consideration as well the first function to get the folder we want to apply the second code to.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = GetFolder("C:\users\yourname\Desktop" 'Modify as needed.
MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed.
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
See what happened there? We called the GetFolder function and assigned it to MyFolder. We then concatenate MyFolder and a wildcarded string, then pass it to Dir so we can loop over the files. What's the remaining two things? Right, count the used rows AND moving the files. For the used rows, I'll hack a simple function to check the workbook's only sheet to see if the row is 2 or greater.
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 'Modify as necessary.
End Function
Now that's simple enough. Next, let's write a simple code to move the files. For personal purposes, I'll write a code to copy instead. It'll be up to you to modify it for moving, as that's a rather sensitive operation and if it messes up... well. Hmm. But something here tells me that there's a much better option. Copying can cause all manners of error from permission denial to erroneous copying. Since we've got the file open, why not just save them instead to the new folder?
Now, let's tie them all together neatly.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\yourname\Desktop") 'Modify as needed.
MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed.
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\yourname\Desktop\Blah\CopyOf" & MyFile 'Modify as needed.
End If
.Close
End With
MyFile = Dir
Loop
Shell "explorer.exe C:\Users\yourname\Desktop\Blah", vbMaximizedFocus 'Open the folder.
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 'Modify as necessary.
End Function
Tried and tested. Let us know if this works for you.
Nice answer from Manhattan: that's exactly how I use Excel's built-in functionality to select a folder and fetch a set of file names.
However, there's an interesting side-question in there:
Are those single-sheet Excel files workbooks, of just .csv text files?
If they have a .csv extension, you don't need to open them in Excel to count the rows!
Here's the code to do it:
Fast VBA for Counting Rows in a CSV file
Public Function FileRowCount(FilePath As String, Optional RowDelimiter As String = vbCr) As Long
' Returns the row count of a text file, including the header row
' Returns - 1 on error
' Unicode-compliant, works on UTF-8, UTF-16, ASCII, with or without a Byte order Marker.
' Reads a typical 30Mb file over the network in 200-300ms. Hint: always copy to a local folder.
' If you're scanning files for use with a SQL driver, use basSQL.TableRowCount: it's 20x slower,
' but it returns a proper test of the file's usability as a SQL 'table'
' Nigel Heffernan Excellerando.Blogspot.com 2015
' Unit test:
' s=Timer : for i = 0 to 99 : n=FileRowCount("C:\Temp\MyFile.csv") : Next i : Print Format(n,"#,##0") & " rows in " & FORMAT((Timer-s)/i,"0.000") & " sec"
' Network performance on a good day: reads ~ 150 MB/second, plus an overhead of 70 ms for each file
' Local-drive performance: ~ 4.5 GB/second, plus an overhead of 4 ms for each file
On Error Resume Next
Dim hndFile As Long
Dim lngRowCount As Long
Dim lngOffset As Long
Dim lngFileLen As Long
Const CHUNK_SIZE As Long = 8192
Dim strChunk As String * CHUNK_SIZE
If Len(Dir(FilePath, vbNormal)) < 1 Then
FileRowCount = -1
Exit Function
End If
' trap the error of a folder path without a filename:
If FileName(FilePath) = "" Then
FileRowCount = -1
Exit Function
End If
hndFile = FreeFile
Open FilePath For Binary Access Read Shared As #hndFile
lngFileLen = LOF(hndFile)
lngOffset = 1
Do Until EOF(hndFile)
Get #hndFile, , strChunk
FileRowCount = FileRowCount + UBound(Split(strChunk, RowDelimiter))
Loop
Close #hndFile
Erase arrBytes
End Function
Public Function FileName(Path As String) As String
' Strip the folder and path from a file's path string, leaving only the file name
' This does not check for the existence or accessibility of the file:
' all we're doing here is string-handling
' Nigel Heffernan Excellerando.Blogspot.com 2011
Dim strPath As String
Dim arrPath() As String
Const BACKSLASH As String * 1 = "\"
strPath = Trim(Path)
If strPath = "" Then Exit Function
If Right$(strPath, 1) = BACKSLASH Then Exit Function
arrPath = Split(strPath, BACKSLASH)
If UBound(arrPath) = 0 Then ' does not contain "\"
FileName = Path
Else
FileName = arrPath(UBound(arrPath))
End If
Erase arrPath
End Function
Note the use of the Split function to count the row separators: VBA's string-handling is generally slow, especially when you concatenate strings, but there are a couple of places where VBA can perform a string manipulation without internal allocation and deallocation; if you know where they are, you'll find that parts of your code run as fast as a 'C' developer's best work.
Warning: Horrible Hack
Strictly speaking, I should declare Dim arrBytes(CHUNK_SIZE) As Byte and use this Byte array instead of strChunk to receive the Get from a file opened for binary read.
There are two reasons for not doing it the 'right' way:The last Get, which will set end-of-file TRUE, will extract less data from the file than the full 'chunk'. What happens next is that these last few bytes of the file are written into the array without clearing out the data from the previous 'Get'. So you have to do additional plumbing, counting bytes off against LOF(#hwndFile) to detect the 'Last Get' and branching into a statement that clears the buffer, or allocates a smaller byte array and uses that instead;The code will only cope with UTF-8 2-byte encoded character sets, or with single-byte encoded ASCII 'Latin' text if you do a bit of byte-array substitution around your row delimiters.The VBA String type is a byte array with a wrapper that allows your code (or rather, the compiler) to handle all that complexity in the background.
However, it's much faster to go back into the primordial C, using old-school Get statements, than using later libraries like Scripting.FileSystemObject. Also, you have some ability to examine the incoming data at the byte level, to debug issues where you're getting '???????' characters instead of the text you were expecting.
Anyway: this is late to the game, as StackOverflow answers go, and it's an answer to the less-interesting part of your question. But it's going to be interesting to people who need a quick rowcount in their data files, and your question comes at the top of the list when they search for that.