I have created a Command Button on my work sheet with the following codes. My excel file has more than 80 sheets. Now the issue in this list appears partially due to a big list. (first 40 items only)
How can I divide this list into 2 or 3 vertical lists?
Private Sub CommandButton1_Click()
Dim myList As String
Dim mySht
For i = 1 To ActiveWorkbook.Sheets.Count
myList = myList & i & " - " & ActiveWorkbook.Sheets(i).Name & " " & vbCr
Next i
mySht = InputBox("Select Sheet to go to." & vbCr & myList)
If mySht = "" Then
'MsgBox "User pressed CANCEL or empty string is submitted"
Exit Sub
End If
If Not IsNumeric(mySht) Or mySht < 1 Or mySht > ActiveWorkbook.Sheets.Count Then
MsgBox "Wrong input"
Exit Sub
End If
ActiveWorkbook.Sheets(CInt(mySht)).Select
End Sub
You are creating a list and entering it in the prompt where there isn't enough space. I suggest creating a custom form with a listbox like so:
Go to the VBA screen
Insert Userform
Add a Listbox
Add a Command button
Enter this code in the Userform module
Option Explicit
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To ActiveWorkbook.Sheets.Count
Me.ListBox1.AddItem ActiveWorkbook.Sheets(i).Name
Next i
End Sub
Private Sub CommandButton1_Click()
Dim myStr As String
myStr = Me.ListBox1
ActiveWorkbook.Sheets(myStr).Activate
Me.Hide
End Sub
Then have your command button open the userform
Related
I would like to generate some code that allows an end user to select one of many charts from a sheet, after which I will do a bunch of manipulation based on that selection.
I am looking for something similar to the Application.Inputbox Type:=8 that allows for an object selection instead of a range selection.
Am I asking to much of humble old VBA??
It's a lot easier to select the chart first, then run code on the selected chart(s), than it is to pause the code and try to select the chart(s) from within the code.
But it can be done.
You need a userform, called F_ChartChooser with two buttons, btnCancel and btnContinue.
The code in the F_ChartChooser module:
Option Explicit
Private Sub btnCancel_Click()
CancelProcedure
End Sub
Private Sub btnContinue_Click()
ContinueProcedure
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' so clicking red X doesn't crash
If CloseMode = 0 Then
Cancel = True
CancelProcedure
End If
End Sub
The code in the regular module consists of a main procedure which must get the chart(s) from the user. It has to call the userform modelessly so the user can select charts in the worksheet. This means the code continues running while the form is displayed, so the thing to do is end the sub when the userform is called.
Based on what happens with the userform, the code either continues with CancelProcedure or with ContinueProcedure. Here's the code:
Option Explicit
Dim mfrmChartChooser As F_ChartChooser
Sub Main()
' code here
' need to select chart(s) here
Application.Goto ActiveCell
Set mfrmChartChooser = New F_ChartChooser
mfrmChartChooser.Show vbModeless
End Sub
Sub CancelProcedure()
Unload mfrmChartChooser
Set mfrmChartChooser = Nothing
MsgBox "User canceled.", vbExclamation
End Sub
Sub ContinueProcedure()
Unload mfrmChartChooser
Set mfrmChartChooser = Nothing
If Not ActiveChart Is Nothing Then
' do something with active chart
' this demo is announcing that it was selected
MsgBox """" & ActiveChart.ChartTitle.Text & """ was selected.", vbExclamation
' end of demo code
ElseIf TypeName(Selection) = "DrawingObjects" Then
Dim sh As Shape
Dim vCharts As Variant
Dim nChart As Long
ReDim vCharts(0 To nChart)
For Each sh In Selection.ShapeRange
If sh.HasChart Then
' do something here with each chart
' this demo is building a list of selected charts
nChart = nChart + 1
ReDim Preserve vCharts(0 To nChart)
vCharts(nChart) = sh.Chart.ChartTitle.Text
' end of demo code
End If
Next
' this demo now is showing the list of selected charts
If nChart = 0 Then
MsgBox "No chart selected.", vbExclamation
Else
If nChart = 1 Then
MsgBox """" & vCharts(nChart) & """ was selected.", vbExclamation
Else
Dim sPrompt As String
sPrompt = nChart & " charts selected:" & vbNewLine & vbNewLine
Dim iChart As Long
For iChart = 1 To nChart
sPrompt = sPrompt & """" & vCharts(iChart) & """" & IIf(iChart < nChart, vbNewLine, "")
Next
MsgBox sPrompt, vbExclamation
End If
End If
' end of demo code
Else
' do nothing because no chart was selected
' this demo is announcing that nothing was selected
MsgBox "No chart selected.", vbExclamation
' end of demo code
End If
End Sub
The CancelProcedure and ContinueProcedure routines above have excess code in them just to help with the demo. In real code I would streamline them like this, probably not even bother to notify the user when nothing was selected (they know they canceled, right?), and just process the selected chart(s):
Sub CancelProcedure()
Unload mfrmChartChooser
Set mfrmChartChooser = Nothing
End Sub
Sub ContinueProcedure()
Unload mfrmChartChooser
Set mfrmChartChooser = Nothing
If Not ActiveChart Is Nothing Then
' do something with active chart
ProcessChart ActiveChart
ElseIf TypeName(Selection) = "DrawingObjects" Then
Dim sh As Shape
Dim vCharts As Variant
Dim nChart As Long
ReDim vCharts(0 To nChart)
For Each sh In Selection.ShapeRange
If sh.HasChart Then
' do something here with each chart
ProcessChart sh.Chart
Next
End Sub
I have a userform which has one listbox which displays the names of worksheets in the activeworkbook. When I double click on any of the sheet name listed in the listbox it takes me to that sheet.
In the same userform I also have textbox in which whatever I will type in it will change the active sheet name to that.
All the above queries codes are working.
Now I want another feature that whatever sheet name I have selected from listbox that sheet name should reflect in my textbox as well.
Please let me know what code should I use.
Please find below the codes which I have used so far to get the list of sheets in my listbox and to change the sheet name by typing the name in the textbox.
Private Sub CommandButton1_Click()
'unload the userform
Unload Me
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
Application.ScreenUpdating = False
Dim i As Integer, Sht As String
'for loop
For i = 0 To ListBox1.ListCount - 1
'get the name of the selected sheet
If ListBox1.Selected(i) = True Then
Sht = ListBox1.List(i)
End If
Next i
'test if sheet is already open
If ActiveSheet.Name = Sht Then
MsgBox "This sheet is already open!"
Exit Sub
End If
'select the sheet
Sheets(Sht).Select
'reset the userform
Unload Me
frmNavigation.Show
End Sub
Private Sub Sheetnametext_Change()
'If the length of the entry is greater than 31 characters, disallow the entry.
If Len(Sheetnametext) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & "You entered " & mysheetname & ", which has " & Len(mysheetname) & " "
characters.", , "Keep it under 31 characters"
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Sheetnametext, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & "Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Sheetnametext)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'History is a reserved word, so a sheet cannot be named History.
If UCase(mysheetname) = "HISTORY" Then
MsgBox "A sheet cannot be named History, which is a reserved word.", 48, "Not allowed"
Exit Sub
End If
'If the worksheet name does not already exist, name the active sheet as the InputBox entry.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
End If
End Sub
Private Sub UserForm_Initialize()
Dim Sh As Variant
'for each loop the add visible sheets
For Each Sh In ActiveWorkbook.Sheets
'add sheets to the listbox
Me.ListBox1.AddItem Sh.Name
Next Sh
End Sub
Need a Listbox_Change event. Something like this should work for you:
Private Sub ListBox1_Change()
Dim i As Long
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
Me.Sheetnametext.Text = Me.ListBox1.List(i)
Exit For
End If
Next i
End Sub
i tried various methods to select multiple sheets in the list box and returning the selected sheet names into the msgbox. can any one help doing this.
currently i am able to populate the sheet names in the list box.However i am not getting the all selected sheet names in the msgbox.
Public listChoice As String
Private Sub UserForm_Activate()
For n = 1 To ActiveWorkbook.Sheets.Count
With ListBox1
.AddItem ActiveWorkbook.Sheets(n).Name
End With
Next n
End Sub
Private Sub ListBox1_AfterUpdate()
listChoice = ListBox1.Text
End Sub
Private Sub CommandButton1_Click()
MsgBox (listChoice)
End Sub
Getting the selected item in a listbox isn't as straightforward as you'd want it to be:
Private Sub CommandButton1_Click()
Dim Msg As String
Dim i As Integer
Msg = "You selected" & vbNewLine
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
Msg = Msg & ListBox1.List(i) & vbNewLine
End If
Next i
MsgBox Msg
End Sub
credit: http://www.java2s.com/Code/VBA-Excel-Access-Word/Forms/GettheselecteditemsinaListBox.htm
You don't need the ListBox1_AfterUpdate() Sub or the public listChoice variable with this code
This msgbox the selected items in listbox.
Private Sub CommandButton1_Click()
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
Msg = ListBox1.List(i) & vbNewLine
End If
Next i
MsgBox Msg
End Sub
Something like this may assist,
Private strOP As String
Private dicSelections As Scripting.Dictionary
Private Sub ListBox1_Mouseup(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim strSheet As String
strSheet = Me.ListBox1.List(Me.ListBox1.ListIndex)
If Me.ListBox1.Selected(Me.ListBox1.ListIndex) Then
If Not dicSelections.Exists(strSheet) Then
dicSelections.Add strSheet, strSheet
Else
End If
Else
If dicSelections.Exists(strSheet) Then
dicSelections.Remove strSheet
End If
End If
End Sub
Private Sub UserForm_Click()
Me.ListBox1.AddItem "one"
Me.ListBox1.AddItem "two"
Me.ListBox1.AddItem "three"
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Debug.Print "Worksheets selected " & Join(dicSelections.Items(), " & ")
End Sub
Private Sub UserForm_Initialize()
Set dicSelections = New Scripting.Dictionary
End Sub
I have done 2 separate prog till now.
One displays a message box before closing a workbook:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
question = "Display all the sheets which are Unprotected"
answer = MsgBox(question, vbYesNo)
If answer = vbNo Then
MsgBox "complete everything and then close"
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Another displays in a new sheet "Unprotected", list of all the unprotected sheets.
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False And ws.Name <> "Unprotected" Then
CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
End If
Next
End Sub
I want a Message box to appear if I try to close the worksheet and if any sheet is unprotected, the message box displays the names of the unprotected sheets. I am facing problem in combining the above 2 codes.
I am not a VBA expert and I am trying it but unable to solve it.
Something like this can show you a list of the unprotected sheets. However, it's probably better to just use VBA to force their protection, rather than prompting the user to do it (unless they need to provide a password for protection status).
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
Dim unprotected as String
unprotected = GetUnprotectedSheets(ThisWorkbook)
If unprotected <> vbNullString Then
MsgBox "Please protected the following worksheets before closing" & vbCRLF & unprotected
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Function GetUnprotectedSheets(wb as Workbook)
'Custom function to return a string of sheet names
' which are unprotected
Dim ret as String
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then
ret = IIF(ret = "", ws.Name, ret & vbCRLF & ws.Name)
End If
Next
GetUnprotectedSheets = ret
End Function
You can call a procedure like this to ensure all sheets are protected:
Sub ProtectAllSheets(wb as Workbook)
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then ws.Protect
Next
End Sub
Just add a counter to your second script:
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
Dim iCounter As Integer, strMessage As String 'Adding a counter variable & string
'ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
iCounter = 0 'Initialize it
strMessage = "" 'Initialize empty string for the message box
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False Then
iCounter = iCounter + 1 'Keeping track of any unprotected sheet
' CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
' Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
strMessage = strMessage & ws.Name & " "
End If
Next
' Here you can do your msgbox or any other action if unprotected sheet detected
If iCounter > 0 Then
MsgBox ("These sheets are unprotected: " & strMessage)
End If
End Sub
EDIT:
To enclose that within a button click: add an activeX button to your form, then:
Private Sub CommandButton1_Click()
'E.g. make the sub a commmandbutton_click() event
End Sub
Actually, when you add the button to your form, if you right-click on it you have the option "View code" - this will create an associated Commandbutton_click like I showed above.
I have a userform which I wish to pass a range to. I have tried a couple of different ways to do it but does not seem to work.
Here is the sub code:
Option Explicit
Sub Additional_Comments_Normal()
Dim MSG1 As Integer
Dim msg As String
Dim act As Range
On Error GoTo ErrHandler
'Calls userform
MSG1 = MsgBox("Would you like to add comments", vbYesNo, "Add comments")
If MSG1 = vbYes Then
With AddComments
On Error Resume Next
Set act = Application.InputBox(Prompt:="Please choose files you wish to add comments to", Type:=8)
If act Is Nothing Then
Exit Sub
End If
Application.ScreenUpdating = True
.Show
End With
Else
Exit Sub
End If
ErrHandler:
If Err.Number <> 0 Then
msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
And the userform code is here:
Public act As Range
Private Sub CommandButton1_Click()
Dim ctl As Control
Dim rng As Range
Dim MSG2 As Integer
Dim sfile As String
If act.Column > 1 Then
MsgBox ("Please choose File name from Column 1")
Exit Sub
End If
If act.Row < 4 Then
MsgBox ("Please choose a valid file")
Exit Sub
End If
If Me.TxtComment.Value = "" Then
MsgBox "Please add comments", vbExclamation, "Additional Comments"
Me.TxtComment.SetFocus
Exit Sub
End If
If Me.TxtName.Value = "" Then
MsgBox "Please add your name", vbExclamation, "Additional Comments"
Me.TxtName.SetFocus
Exit Sub
End If
MSG1 = MsgBox("Add Comments ?", vbYesNo, "Add comments")
If MSG1 = vbNo Then
End If
If MSG1 = vbYes Then
act.Offset(0, 16).Value = act.Offset(0, 16).Text & " " & Me.TxtComment.Value
act.Offset(0, 17).Value = act.Offset(0, 17).Text & " " & Me.TxtName.Value
For Each ctl In Me.Controls
If TypeName(ctl) = "TextBox" Then
ctl.Value = ""
End If
Next ctl
AddComments.Hide
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End If
End Sub
Private Sub CommandButton2_Click()
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
I then get an error about the act not being defined variable.
Can anyone shed some light on better process for this?
You have set Option Explicit at the top of your code. That means that all variables need to be defined (which is considered good programming practice). So, you have two options to resolve this:
(1) Remove the line Option Explicitfrom your code or
(2) define all of your variables using the Dim command. In this case you'd have to add Dim act as Range to your Sub CommandButton1_Click on the form.
If you want to pass a variable to another sub then you can do so calling that sub with that variable like so:
Call Additional_Comments_Normal(act)
and the sub header neeeds to change like so:
Sub Additional_Comments_Normal(ByVal act as Range)
'(your code)'
End Sub
If "passing a variable to another sub" is too much trouble then you can also save the range somewhere in your file like so:
SomeHiddenSheet.Range("A1").Value2 = act
and in the other sub you can initiate act again:
act = SomeHiddenSheet.Range("A1").Value2