Excel VBA, using FileDialog to open multiple workbooks and reference them - vba

I am currently using to following code to prompt the user for a workbook, open it, get some information from it and then close it. at the moment, I address the opened workbook by using the workbooks collection with and index ("woorkbooks(2)"). Now I need to open two workbooks, and my problem is that I wouldn't know which of the workbooks will be indexed as 2 and which will be indexed as 3. So, I figured there must be a way to get a reference to each workbook.
Function openfile() As Boolean
Dim fd As FileDialog
Dim file_was_chosen As Boolean
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Excel File", "*.xl*"
End With
file_was_chosen = fd.Show
If Not file_was_chosen Then
MsgBox "You didn't select a file"
openfile = False
Exit Function
End If
fd.Execute
openfile = True
End Function
Now I've seen some solutions to this problem involving getting the full path of each workbook, but I'd prefer avoid using the full path since it contains words in different language (and the name of the workbook appears with question marks). Moreover, I'd prefer a solution in which the user is promped only once for 2 files and not twice.

This version gives the user a single dialog. Enjoy. And whoever downvoted my other answer, please add a comment to that explaining what you so disliked about it that it required a downvote.
Function openfile() As Variant
Dim aOpen(2) As String, itm As Variant, cnt As Long, lAsk As Long
Dim fd As FileDialog
Dim file_was_chosen As Boolean
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Excel File", "*.xl*"
End With
Do
file_was_chosen = fd.Show
If Not file_was_chosen Or fd.SelectedItems.Count > 2 Then
lAsk = MsgBox("You didn't select one or two files, try again?", vbQuestion + vbYesNo, "File count mismatch")
If lAsk = vbNo Then
openfile = aOpen
Exit Function
End If
End If
Loop While fd.SelectedItems.Count < 1 Or fd.SelectedItems.Count > 2
cnt = 0
For Each itm In fd.SelectedItems
aOpen(cnt) = itm
cnt = cnt + 1
Next
openfile = aOpen
fd.Execute
End Function
Sub test()
Dim vRslt As Variant
Dim wkb As Excel.Workbook, wkb1 As Excel.Workbook, wkb2 As Excel.Workbook
vRslt = openfile
For Each wkb In Application.Workbooks
If wkb.Path & "\" & wkb.Name = vRslt(0) Then Set wkb1 = wkb
If wkb.Path & "\" & wkb.Name = vRslt(1) Then Set wkb2 = wkb
Next
If vRslt(0) = "" Then ' no files
MsgBox "No files opened so nothing happens..."
ElseIf vRslt(1) = "" Then ' one file was opened
MsgBox "One file so do whatever you want for one file"
Else ' two files were opened
MsgBox "Two files so do whatever you want for two files"
End If
End Sub

Working with your existing openfile function, change the return from Boolean to Excel.Workbook. If they don't open a workbook you set it to Nothing instead of false, otherwise you set it to the workbook reference of the file you just opened (You'll need to modify openfile to get that reference). You then just call it twice and set a workbook reference for each call that is not Nothing.
Example code below is written freeform and is untested - it's really just glorified pseudocode - but should point you the right general direction.
sub test
dim lAsk as long
dim wkb1 as excel.workbook
dim wkb2 as excel.workbook
do
if wkb1 is Nothing then
set wkb1 = openfile
if wkb1 is Nothing then
lAsk = msgbox("you didn't select a first file, try again?",vbyesno,"No file selected")
if lAsk = vbNo then exit do
end if
elseif wkb2 is Nothing then
set wkb2 = openfile
if wkb2 is Nothing then
lAsk = msgbox("you didn't select a second file, try again?",vbyesno,"No file selected")
if lAsk = vbNo then exit do
end if
end if
loop while wkb1 is Nothing or wkb2 is Nothing
' do whatever with wkb1 and wkb2 here
end sub
Edited to add:
Here's a very basic shape for your revised openfile function. Again, untested but I've modified it from one of my own procs so it should work
Function openfile() As Excel.Workbook
Dim sFilter As String
Dim sTitle As String
Dim vFileName As Variant
sFilter = "Excel Files (*.xl*), *.xl*, CSV Files (*.csv), *.csv, All Files (*.*), *.*"
sTitle = "Select file to process"
vFileName = Application.GetOpenFilename(filefilter:=sFilter, Title:=sTitle)
If vFileName = False Then
Set openfile = Nothing
Else
Set openfile = Workbooks.Open(Filename:=vFileName)
End If
End Function

Related

Excel VBA Copy a Workbook to another one with Dialog

I am a beginner in Excel VBA programming and am tasked to develop a Tool in Excel for monitoring. I do have knowledge in other Languages like Java, C++ and Python, therefore I know how to do the Logic, but VBA is a difficult one.
The Thing:
What I need to get working is the following:
I have a Workbook, lets call it Tool.xlsm in which I've wrote the sorting and filtering logic. This part is working fine. It uses a seperate sheet in that workbook for the "background data". This sheet is what this is about.
I want to write a macro which displays a file selection dialouge. The selected file then gets copied to a new sheet in my Workbook. The file is a .xls table with 3 sheets. The data needed is in sheet 1.
Public Sub copyData()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
sourceFileName = "FileToCopy.xlsx"
'Open Source File.xlsx
With appxl
.Workbooks.Open ActiveWorkbook.Path & "\" & sourceFileName
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = appxl.Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Sheets("Data retrieval").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y"& lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub
This is the Code I wrote with the help of the famous GoogleSearch.
Now to the Specific Questions:
How do I code a FileSelectionDialouge?
how do I fix the error 9, outofBounds?
Ive searched in Stackoverflow for quite some time, but didnt find a similar problem.
This is my first Post here, I apologize for any mistakes made.
Also I apologize for any grammar or vocabular mistakes, english is not my native language :)
Many thanks for reading.
Ninsa
Edit: Ive modified the code according to the answers below. It now looks like this:
Public Sub copyData2()
Set appxl = CreateObject("Excel.application")
Dim myfile As Window
Dim currentSheet As Worksheet
Dim lastRow As Double
Dim sourceFileName As String
'Ask the user to select a file
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.ButtonName = "Import File"
.InitialView = msoFileDialogViewSmallIcons
.Title = "Please Select File"
If .Show = -1 Then Collation_File = .SelectedItems(1)
End With
sourceFileName = Collation_File
'Open Source File.xlsx
With appxl
.Workbooks.Open Collation_File
.Visible = False
End With
'Get first sheet data
Set myfile = appxl.Windows(sourceFileName)
myfile.Activate
Set currentSheet = Workbooks("sourceFileName").Sheets(1)
'Past the table in my current Excel file
lastRow = currentSheet.Range("A1").End(xlDown).Row
Debug.Print lastRow
Sheets("test").Range("A1:Y" & lastRow) = currentSheet.Range("A1:Y" & lastRow).Value
'Close Source File.xlsx
appxl.Workbooks(sourceFileName).Close
End Sub
For the first part you could use the following function based on this article in MSDN
Function GetFileName() As String
GetFileName = ""
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
If .Show = -1 Then
GetFileName = .SelectedItems(1)
End If
End With
End Function
Update I re-wrote your code to
Public Sub copyData()
Dim sourceWkb As Workbook
Dim sourceWks As Worksheet
Dim targetWks As Worksheet
Dim sourceFilename As String
Dim lastRow As Long
Set targetWks = Sheets("Data retrieval")
sourceFilename = GetFileName
Set sourceWkb = Workbooks.Open(sourceFilename)
Set sourceWks = sourceWkb.Sheets(1)
'Past the table in my current Excel file
lastRow = sourceWks.Range("A1").End(xlDown).Row
targetWks.Range("A1:Y" & lastRow) = sourceWks.Range("A1:Y" & lastRow).Value
'Close Source File.xlsx
sourceWkb.Close False
End Sub
With Application.ScreenUpdating = Falseyou can turn off screen flickering.

Combining macros in Excel

I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function

VBA moving excel sheet to another workbook with unknown extension

Worksheets("Hello").Move After:=Workbooks("FILE2").Sheets(1)
I have two open active files. Hello.xlsb and FILE2.xlsb
The above code only works on my computer but not on shared drive.
I am getting "Subscript out of range error".
We need to specify the extension FILE2.xlsb to make it work.
However, I want this to work on any FILE2 with any extension.
How to make that work?
This code will ask you to open the destination workbook and move the sheet into it, is it what you're after?
Public Sub Test()
Dim vfile As Variant
Dim wrkBk As Workbook
'Ask for the location of File2.
vfile = GetFile(ThisWorkbook.Path)
Set wrkBk = Workbooks.Open(vfile)
ThisWorkbook.Worksheets("Hello").Move After:=wrkBk.Worksheets(1)
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 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
If your destination workbook is already open, then you can use this to safely refer to a workbook regardless of extension:
Function GetWb(wbName As String)
Dim wb As Workbook, rv As Workbook
For Each wb In Application.Workbooks
If UCase(wb.Name) Like UCase(wbName & ".*") Then
Set rv = wb
Exit For
End If
Next wb
Set GetWb = rv
End Function
Usage
Dim destWb As Workbook
Set destWb = GetWb("file2")
if destWb Is Nothing then
Msgbox "destination file not open!"
else
'perform the copy
end if
FYI this may be why you see differences between computers:
Windows().Activate works on every computer except one

Prompt user to select a worksheet

I have a Macro, that prompts a user to select an Excel file, like this:
Dim thisBook As Workbook, newBook As Workbook
Dim fd As FileDialog
Dim oFD As Variant
Dim fileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.ButtonName = "Select"
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xls", 1
.Title = "Choose the Report"
.InitialView = msoFileDialogViewDetails
.Show
For Each oFD In .SelectedItems
fileName = oFD
Next oFD
On Error GoTo 0
End With
If fd.SelectedItems.Count = 0 Then
Exit Sub
End If
Set thisBook = ActiveWorkbook
Set newBook = Workbooks.Open(fileName)
This works fine, what I want to do now, and what I failed to find in the internet is the following:
I want to prompt the user to select a worksheet from the newbook, since the sheet name could not be the same in the future.
I came up with this, but I am not very happy with it, since it is rather inconvenient, to let the user type the sheet name:
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
Function q() As String
Dim shname As String
Do Until WorksheetExists(shname)
shname = InputBox("Enter sheet name")
If Not WorksheetExists(shname) Then MsgBox shname & " doesn't exist!", vbExclamation
Loop
q = shname
End Sub
Is there a way, to maybe let the user select the sheet name, from all the sheet names? (I am not using an Userform, the Macro starts, if the user clicks a Button)
Make a userform with a blank ListBox and use this code in the userform module
Private Sub UserForm_Initialize()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
ListBox1.AddItem sh.Name
Next sh
End Sub
Private Sub ListBox1_Click()
Sheets(ListBox1.Value).Activate
Unload Me
End Sub
Use an InputBox and have the user select any cell inside the desired/target sheet. Setting the type to 8 returns a Range. From this range, you can get the worksheet then its name.
Dim desiredSheetName as String
desiredSheetName = Application.InputBox("Select any cell inside the target sheet: ", "Prompt for selecting target sheet name", Type:=8).Worksheet.Name
Debug.Print desiredSheetName

Browsing Main excel file and Save As directory path with use of Excel VBA

I have below Excel procedure I gather up and I am using it for couple of different calculations under different workbooks. So I was thinking instead changing the procedure for main and outcome files each time, I should be able to pick the file I want to carry out calculations in and the file path for outcomes files.
But I could not find anything for saving directory, I appreciate if you could help
Sub AsBuiltForm()
Dim SaveName As String
Dim mainBook As Workbook
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
Workbooks.Open Filename:="C:\" 'main file can be browsed?
Set mainBook = Excel.Workbooks("CP.xlsx")
For i = a - 1 To b - 1
mainBook.Sheets(1).Range("bi1") = i + 1
SaveName = Sheets(1).Range("bi1").value & ".xlsx"
mainBook.SaveCopyAs "C:\" & SaveName 'save directory?
Workbooks.Open Filename:="C:\" & SaveName 'save directory?
With Excel.ActiveWorkbook
.Sheets("1 of 2").Range("A1:CT103").value = Sheets("1 of 2").Range("A1:CT103").value
.Sheets("2 of 2").Range("A1:CT103").value = Sheets("2 of 2").Range("A1:CT103").value
Excel.Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("il oufall").Delete
.Sheets("1 of 2").Select
Columns("Bh:BZ").Select
Selection.Delete Shift:=xlToLeft
.Sheets("2 of 2").Select
Columns("Bn:BZ").Select
Selection.Delete Shift:=xlToLeft
.Close True
End With
Next
mainBook.Close False
Set mainBook = Nothing
End Sub
You can use Application.GetOpenFileName to pick files that you want to open at Run-Time.
You can use the function below to browse for a folder where you wish to save a file.
Sub FindFolder()
Dim myFolder as String
myFolder = BrowseFolder("Pick a Folder Where to Save")
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.path
End If
End If
End Function
The following is not really an answer to your question, but a few tips to improve your code, and too long to add as a comment.
Workbooks.Open returns a Workbook object you can save the reference, so you don't have to rely on ActiveWorkbook:
Dim oWorkbook As Workbook
Set oWorkbook = Workbooks.Open(Filename:="C:\" & SaveName)
'***** Do something with oWorkbook
Debug.Print oWorkbook.FullName
Set oWorkbook = Nothing
A few other hints:
Use Option Explicit at the top of every module to force explicit declaration of all variables in order to find typos and other errors earlier.
Avoid selecting cells
Yes, browsing file works now; all the ins and outs aside, the problem i face with naming the file due to the variable "bi1" and saving as many loop as i asked for. I check several times before i bother you but i do not think i have the sufficient info to address "fn" as file in the use of Application.GetOpenFileName .
Option Explicit
Sub AsBuiltForm()
Dim fn
Dim myFolder As String
Dim SaveName As String, a As Integer, b As Integer, i As Integer
myFolder = BrowseFolder("Pick a Folder Where to Save")
MsgBox "Choose Calculation File "
fn = Application.GetOpenFilename
Workbooks.Open fn
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
For i = a - 1 To b - 1 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:=fn
Range("bi1") = i + 1
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Sheets(1).Range("A1:CT103").value = Sheets(1).Range("A1:CT103").value
Sheets(2).Range("A1:CT103").value = Sheets(2).Range("A1:CT103").value
Application.ActiveWorkbook.SaveAs myFolder & SaveName
ActiveWorkbook.Close True
Next
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.Path
End If
End If
End Function