Prompt user to select a worksheet - vba

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

Related

User Selection (workbook and sheet name) then Copy and Paste

Is there a way to make it where user selects which sheet to copy from, after they opened file?
I'd like to do this because there may be multiple sheets with same format, but have different names.
Example:
Original workbook named VSC (Contains sheets Compare, Plot)
Secondary workbook named SF (Contains sheets Results1, Results2, Results3)
User clicks button on VSC, and file dialog opens, and user selects SF in a certain directory, then asks user to select which sheet to choose from - user chooses Results2 sheet, copies the data (Range"B2:B5"), then pastes it back to Compare sheet.
Would this be possible? I am not sure how to start.
Current code that asks user to select SF workbook:
Sub GetFilePath()
Dim objFSO as New FileSystemObject
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose File"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Here is one approach. You type in the sheet name. Adjust copy and paste ranges to suit.
Sub GetFilePath()
Dim objFSO As New FileSystemObject, w As String, wb As Workbook
Application.ScreenUpdating = False
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose File"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
Set wb = Workbooks.Open(.SelectedItems(1))
End With
w = InputBox("Enter sheet name")
If SheetExists(w) Then
wb.Sheets(w).Range("B2:B5").Copy
ThisWorkbook.Sheets("Compare").Range("A1").pastespecial xlvalues
Else
MsgBox "Sheet not found"
End If
wb.Close False
Application.ScreenUpdating = True
End Sub
Function SheetExists(s As String) As Boolean
Dim x
On Error GoTo NextSheet
x = ActiveWorkbook.Sheets(SheetName).Name
SheetExists = True
Exit Function
NextSheet:
SheetExists = False
End Function
Once you have your workbook open, you can enumerate the sheets by name and populate a pick list on a sheet in the VSC workbook...
Here is a different approach to your question. It is using a Timer after opening the new Workbook to ask you every 10 seconds if you are on the sheet you want to copy from. If you answer "Yes" it will copy. If you answer "no" it will restart the 10 second timer.
Sub GetFilePath()
Set MyFile = Application.FileDialog(msoFileDialogOpen)
With MyFile
.Title = "Choose File"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FileSelected = .SelectedItems(1)
End With
Set newWk = Workbooks.Open(FileSelected, , True)
'Open Selected Workbook and check in 10 seconds for Selected Sheet Name
Application.OnTime Now + TimeValue("00:00:10"), "CheckForSheet"
End Sub
Private Sub CheckForSheet()
Dim SheetName As String
SheetName = ActiveSheet.Name
answer = MsgBox("Is This the Sheet to copy from: " & SheetName & "?", vbYesNo + vbQuestion, "Copy Data?")
If answer = vbYes Then
'ThisWorkbook is the workbook with the Macro/VBA code
'ActiveWorkbook is the workbook where you are selecting the Sheet to copy from
ActiveWorkbook.Sheets(SheetName).Range("B2:B5").Copy
ThisWorkbook.Sheets("Compare").Range("C1:C4").PasteSpecial
Else
'Check Again in 10 Seconds
Application.OnTime Now + TimeValue("00:00:10"), "CheckForSheet"
End If
End Sub

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

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

Getting Subscription out of range Error

Code is running well while checking if "Test_Worksheet" worksheet exists in workbook file opened by dialog. Workbook File is opening correctly & if "Test_Worksheet" sheet exists in that file then debug.print (in Sub ChkSalfile) give "Name is True".
But if sheet not available in Workbook, then "Subscription out of Range" error coming. Please help. My code is as below
Sub Main()
Dim salefor As Workbook
Dim salpathfileName As String, salfileName As String
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select file."
.Filters.Clear
.Filters.Add "Excel 2003", "*.xls?"
.InitialFileName = "*SAL*.*"
result4 = .Show
If (result4 <> 0) Then
salfileName = Dir(.SelectedItems(1))
salpathfileName = .SelectedItems(1)
Else
'if user pressed CANCEL - exit sub
Application.ScreenUpdating = True
MsgBox "User pressed CANCEL"
Exit Sub
End If
End With
Set salefor = Workbooks.Open(salfileName, ReadOnly:=True)
Call ChkSalfile(salfileName, salefor)
End Sub
Sub ChkSalfile (salfileName As String, salefor As Workbook)
Dim chksalsheet As String
chksalsheet = DoesWorkSheetExist("Test_Worksheet", salfileName)
If chksalsheet = True Then
Debug.Print "Name is " & chksalsheet
Else
Debug.Print "File not found"
End If
End Sub
Option Explicit
Public Function DoesWorkSheetExist(WorkSheetName As String, Optional WorkBookName As String)
Dim WS As Worksheet
On Error Resume Next
If WorkBookName = vbNullString Then
Set WS = Sheets(WorkSheetName)
Else
Set WS = Workbooks(WorkBookName).Sheets(WorkSheetName)
End If
On Error GoTo 0
DoesWorkSheetExist = Not WS Is Nothing
End Function
It seems that your settings in the VBA project editor are set to break on any errors. Change this setting to break only on unhandled errors:
Tools --> Options --> General Tab --> Error Trapping --> check "Break on Unhadled Errors"
That said, don't Dim your variable as a String when it is a Boolean:
Dim chksalsheet As Boolean ' <-- Not as String

Save Worksheets to new Workbook By Checkbox [Excel Macro/VBA]

So my main goal is to save sheets (depending on if they are selected by a checkbox) to a new workbook.
Here is my code:
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim exampleSheet As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") = True Then
exampleSheet = "Example Worksheet 2"
End If
Sheets(Array("Example Worksheet 1"), exampleSheet).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
For example, I want to always save Example Worksheet 1, but only save Example Worksheet 2 if the checkbox is ticked. The cell E29 in Example Worksheet 1 is the linked cell for the checkbox.
So this macro works when the checkbox is ticked, but when the checkbox is unticked, I get an error.
I have set it up so that the sheet array either contains the name or nothing. but when containing nothing, that gives me the error.
Any help would be great.
Edit: I need this for 6 different checkboxes/sheets.
you have one parenthesis too much
then
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim sheetsArray As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") Then
sheetsArray = Array("Example Worksheet 1", "Example Worksheet 2")
Else
sheetsArray = Array("Example Worksheet 1")
End If
Sheets(sheetsArray).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
You can use my example workbook to do this with form:
https://drive.google.com/open?id=0BzFv0oeets6ubHg2bk96SHotdkU
To create this by yourself, here is instructions:
Press ALT+F11 in order to open VBA window;
Create userform with name "Userform1"
Put listbox to form and change its name to "lstSheet"
Change its properties like shown below:
ListStyle: 1-fmListStyleOPtion;
MultiSelect: 1-fmMultiSelectMulti;
Userform code:
Option Explicit
Dim NewName As String
Dim ws As Worksheet
Dim NumSheets As Integer
Private Sub CommandButton1_Click()
Dim Count As Integer, i As Integer, j As Integer
Count = 0
For i = 0 To lstSheet.ListCount - 1
'check if the row is selected and add to count
If lstSheet.Selected(i) Then Count = Count + 1
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select True
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select False
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Activate
Next i
Unload Me
ActiveWindow.SelectedSheets.Copy
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Private Sub lstSheet_Click()
End Sub
Private Sub UserForm_Initialize()
Dim Sh As Variant
'for each loop the add visible sheets
For Each Sh In ActiveWorkbook.Sheets
'only visible sheetand exclude login sheet
If Sh.Visible = True Then
'add sheets to the listbox
Me.lstSheet.AddItem Sh.Name
End If
Next Sh
End Sub
Create Module and put this code there:
Sub showForm()
Userform1.Show
End Sub

Move Sheet to a Visible Excel Instance

I have created a userform in a workbook. When the workbook is opened this is the code that is run:
Private Sub Workbook_Open()
Application.Visible = False
UserForm1.Show
End Sub
So now the user is only seeing the Userform. There is a button on the UserForm that creates a sheet in the invisible running workbook, and MY MAIN OBJECTIVE:
(1) Open a new instance of Excel
(2) Set the new instance of Excel as Visible (Application.Visible = True)
(3) Move the sheet from the invisible instance to the new created visible one.
This is the code I tried running without success:
Sub Move()
' Check if there is a sheet named "Data Sheet"
For Each s In ThisWorkbook.Sheets
If Not s.Name <> "Data Sheet" Then
' if true then create new excel instance
Dim oXLApp As Object, wb As Object
Dim ws As Worksheet
Set oXLApp = CreateObject("Excel.Application")
oXLApp.Visible = True
Set wb = oXLApp.Workbooks.Add
'move the sheet "Data Sheet" to new workbook
s.Move Before:=wb.Sheets(1)
'delete all sheets in new workbook except "Data Sheet"
Application.DisplayAlerts = False
With wb
For Each ws In Worksheets
If ws.Name <> "Data Sheet" Then ws.Delete
Next
End With
Application.DisplayAlerts = True
End If
Next s
End Sub
I managed to move the sheet to a new workbook but within the same invisible excel instance using the below code:
Sub Move2()
Dim newWb As Workbook
Dim ws As Worksheet
For Each s In ThisWorkbook.Sheets
If Not s.Name <> "To Do" Then
Dim sheetName As String
sheetName = s.Name
Set newWb = Workbooks.Add
s.Move Before:=newWb.Sheets(1)
Application.DisplayAlerts = False
With newWb
For Each ws In Worksheets
If ws.Name <> "To Do" Then ws.Delete
Next
End With
Application.DisplayAlerts = True
End If
Next s
End Sub
What is my mistake and what is a good workaround?
As mentioned in the comments above, you cannot move a worksheet to a different instance of Excel. Here is one workaround.
We will use the .SaveCopyAs method to save a copy of the existing workbook. You can read more about .SaveCopyAs HERE
Logic
Save a copy of the existing workbook using .SaveCopyAs in user's temp directory.
Open the copy in a new instance of excel and delete unwanted sheets.
<Optional Step> Re-Save the file (If required) at a new location as .xlsx to remove all macros.
Code (TRIED AND TESTED)
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Dim TempFile As String
Sub MoveSheet()
Dim oXLApp As Object, wb As Object, ws As Object
TempFile = TempPath & "MyFile.xlsm"
On Error Resume Next
Kill TempFile
On Error GoTo 0
ThisWorkbook.SaveCopyAs TempFile
Set oXLApp = CreateObject("Excel.Application")
Set wb = oXLApp.Workbooks.Open(TempFile)
oXLApp.DisplayAlerts = False
For Each ws In wb.Worksheets
If ws.Name <> "Data Sheet" Then ws.Delete
Next
'~~> Optional step to re save the file as xlsx
wb.SaveAs "C:\MyNewFile.xlsx", 51
oXLApp.DisplayAlerts = True
oXLApp.Visible = True
End Sub
'~~> Function to get the user's temp directory
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function