Related
I have a userform with listbox. In the userform the user required to add values in several textboxs, the values automatically are added to an excel table, and the listbox supposed to show the specific values which were added by the user. I have tried to use with Dynamic range through the manager name, and set the rowsource of the listbox to contain the dynamic range, but the listbox is empty and doesn't show any value.
Please your hlp to understand what i'm doing wrong?
The dynamic range is:
Dyn_CurrentCA= =OFFSET(CA_list!$F$4,lists!$V$10,0,lists!$V$9,6)
This is my code:
Public Dep_CA As Integer
Public Target_CA As Integer
Private Sub CB_Add_Click()
Target_CA = Sheets("lists").Range("V8").Value + 1
If T_AuditDate.Value = "" Or CB_Grade.Value = "" Or
T_CAnum.Value = "" Or CB_Subject.Value = "" Or
T_Findings.Value = "" Then
MsgBox "Please fill Audit Date and Audit Result!",
vbRetryCancel + vbCritical, "Data is missing"
Else
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 0).Value = Target_CA
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 1).Value = L_Dep.Caption
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 2).Value = T_AuditDate.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 3).Value = L_Contact.Caption
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 4).Value = L_Manager.Caption
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 5).Value = T_CAnum.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 6).Value = CB_Subject.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 7).Value = CB_SubSubject.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 8).Value = T_Findings.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 9).Value = T_DD.Value
Sheets("CA_list").Range("CA_Start").Offset(Target_CA, 10).Value = CB_Status.Value
Call clear_CA
Dep_CA = Dep_CA + 1
Sheets("lists").Range("V9").Value = Dep_CA
ListBox1.RowSource = Dyn_CurrentCA
End If
End Sub
Private Sub UserForm_Initialize()
Dep_CA = 0 'initialize no. of lines to 0
Sheets("lists").Range("V9").Value = Dep_CA
CurrentRaw = Sheets("lists").Range("V3").Value
Sheets("lists").Range("V10").Value = Sheets("lists").Range("V8").Value + 1
L_Dep.Caption = Sheets("lists").Range("V5").Value
L_Site.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 4).Value
L_PQ.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 5).Value
L_PYear.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 6).Value
L_Auditor.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 7).Value
L_Contact.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 2).Value
L_Manager.Caption = Sheets("Internal_Plan").Range("A_Start").Offset(CurrentRaw, 3).Value
Call clear_CA
With ListBox1
.ColumnWidths = "40;60;60;260;50;40"
.ColumnCount = 6
.RowSource = Dyn_CurrentCA
.ColumnHeads = True
End With
End Sub
Sub clear_CA()
With Update_Results 'name of userform
CB_Subject.Value = ""
CB_SubSubject.Value = ""
T_CAnum.Value = ""
T_DD.Value = ""
CB_Status.Value = "Open"
T_Findings.Value = ""
End With
End Sub
This is the userform with listbox:
Try with using the address of the dynamic range. You need to add the sheet name as well.
ListBox1.RowSource = Worksheets("CA_list").Range("Dyn_CurrentCA").Address(external:=True)
For ActiveX
ListBox1.ListFillRange = Worksheets("CA_list").Range("Dyn_CurrentCA").Address(external:=True)
I need to automatically add buttons to user form in position rigth to selected item in list box.
in excel sheet I'm adding buttons like
Sub buttonsAdd()
Dim btn As Button
Dim t As Range
LastRow = wsAuth.Cells(wsAuth.Rows.count, "A").End(xlUp).row
wsAuth.Buttons.Delete
For i = 1 To LastRow
Set t = wsAuth.Range(wsAuth.Cells(i, 6), wsAuth.Cells(i, 6))
Set btn = wsAuth.Buttons.add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "btnS"
.Caption = SignInButCaption & wsAuth.Cells(i, 1).Value
.Name = "Btn" & i
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.AutoSize = False
End With
Next i
End Sub
Is there a way to add buttons to userform in the same position as listbox.selected(i)?
Is it possible to change listbox.selected(i) font size and style?
All,
I have the below code which creates a dynamic userform based on a list located in an excel worksheet. (Please see picture below)
When the user selects submit I would like to extract all the answers from the user form into an excel file.
Does anyone know how I would do this as I have hit a brick wall in thoughts, the user form to my knowledge has to be built via vba as the list of Project ID & UR can vary from 1 line to thousands of lines.
Any help would be much appreciated.
Sub addLabel()
UserForm6.Show vbModeless
Dim theLabel As Object
Dim ComboBox1 As Object
Dim CommandApp As Object
Dim CommandCan As Object
Dim buttonheight As Long
Dim labelCounter As Long
For Each c In Sheets("Sheet1").Range("A1:A100")
If c.Value = "" Then Exit For
Set theLabel = UserForm6.Controls.Add("Forms.label.1", "Test" & c, True)
With theLabel
.Caption = c
.Left = 10
.Width = 50
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 34
Else
.Top = 25 + (20 * (c.Row - 1)) + 9
End If
End With
Set ComboBox1 = UserForm6.Controls.Add("Forms.combobox.1", "Test" & c, True)
With ComboBox1
.AddItem "Approved"
.AddItem "Partially Approved"
.AddItem "Not Approved"
.Left = 190
.Width = 120
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 30
Else
.Top = 30 + (20 * (c.Row - 1))
buttonheight = 30 + (20 * (c.Row - 1))
End If
End With
Next c
For Each c In Sheets("Sheet1").Range("B1:B100")
If c.Value = "" Then Exit For
Set theLabel = UserForm6.Controls.Add("Forms.label.1", "Test" & c, True)
With theLabel
.Caption = c
.Left = 90
.Width = 70
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 34
Else
.Top = 25 + (20 * (c.Row - 1)) + 9
End If
End With
Next c
With UserForm6
.Width = 340
.Height = buttonheight + 90
End With
Set CommandApp = UserForm6.Controls.Add("Forms.Commandbutton.1", "Test" & c, True)
With CommandApp
.Caption = "Submit"
.Left = 10
.Width = 140
.Font.Size = 10
.Top = buttonheight + 30
End With
Set CommandCan = UserForm6.Controls.Add("Forms.Commandbutton.1", "Test" & c, True)
With CommandCan
.Caption = "Cancel"
.Left = 170
.Width = 140
.Font.Size = 10
.Top = buttonheight + 30
End With
End Sub
You will need create variables to hold references to the newly created CommandButtons. By adding the WithEvents modifier you will be able to receive the CommandButton events.
Naming the controls after cell values is problematic. A better solution is to use the MSForms Control Tag property to hold your references. In my example below I add a qualified reference to the target cell.
Changed the subroutines name from addLabel to something more meaningful Show_UserForm6.
Combobox values as they are added.
Userform6 Module
Option Explicit
Public WithEvents CommandApp As MSForms.CommandButton
Public WithEvents CommandCan As MSForms.CommandButton
Private Sub CommandApp_Click()
Dim ctrl As MSForms.Control
For Each ctrl In Me.Controls
If TypeName(ctrl) = "ComboBox" Then
Range(ctrl.Tag).Value = ctrl.Value
End If
Next
End Sub
Private Sub CommandCan_Click()
Unload Me
End Sub
Refactored Code
Sub Show_UserForm6()
Const PaddingTop = 34, Left1 = 10, Left2 = 90, Left3 = 190
Dim c As Range
Dim Top As Single
Top = 34
With UserForm6
.Show vbModeless
For Each c In Sheets("Sheet1").Range("A1:A100")
If c.Value = "" Then Exit For
With getNewControl(.Controls, "Forms.Label.1", Left1, 50, 20, Top)
.Caption = c.Value
.Tag = "'" & c.Parent.Name & "'!" & c.Address
End With
With getNewControl(.Controls, "Forms.Label.1", Left2, 50, 20, Top)
.Caption = c.Offset(0, 1).Value
.Tag = "'" & c.Parent.Name & "'!" & c.Offset(0, 2).Address
End With
With getNewControl(.Controls, "Forms.ComboBox.1", Left3, 120, 20, Top)
.List = Array("Approved", "Partially Approved", "Not Approved")
.Tag = "'" & c.Parent.Name & "'!" & c.Offset(0, 2).Address
.Value = c.Offset(0, 2).Value
End With
Top = Top + 20
Next
Set .CommandApp = getNewControl(.Controls, "Forms.Commandbutton.1", 10, 140, 20, Top + 10)
With .CommandApp
.Caption = "Submit"
End With
Set .CommandCan = getNewControl(.Controls, "Forms.Commandbutton.1", 170, 140, 20, Top + 10)
With .CommandCan
.Caption = "Cancel"
End With
End With
End Sub
Function getNewControl(Controls As MSForms.Controls, ProgID As String, Left As Single, Width As Single, Height As Single, Top As Single) As MSForms.Control
Dim ctrl As MSForms.Control
Set ctrl = Controls.Add(ProgID)
With ctrl
.Left = Left
.Width = Width
.Font.Size = 10
.Top = Top
End With
Set getNewControl = ctrl
End Function
Generally I'd set up classes and collections to hold references to your new controls.
It can work with your current set up though. First off I'll suggest an aesthetic change:
Set the size of your frame to a static size that fits on your screen and add the two command buttons outside of this.
Size the frame so it sits inside the bounds of your form.
Change the ScrollBars property to 2 - fmScrollBarsVertical.
In your code:
Add a new variable
Dim fme As Frame
Set fme = UserForm6.Frame1
Update your references to UserForm6 so they reference fme instead when you add the labels and combobox:
Set theLabel = fme.Add("Forms.label.1", "Test" & c, True)
.
.
Set ComboBox1 = fme.Controls.Add("Forms.combobox.1", "Test" & c, True)
.
.
Set theLabel = fme.Controls.Add("Forms.label.1", "Test" & c, True)
Outside your final loop add this line of code (you may have to play around with the maths to get the correct scroll height):
fme.ScrollHeight = buttonheight + 90
Remove the code that adds the two command buttons (as they're now static outside of the frame).
Now your whole form should sit on the page and you can scroll through the controls.
Double-click your command button to add a Click event to it:
Private Sub CommandButton1_Click()
Dim ctrl As Control
Dim x As Long
For Each ctrl In Me.Frame1.Controls
If TypeName(ctrl) = "ComboBox" Then
x = x + 1
ThisWorkbook.Worksheets("Sheet2").Cells(x, 1) = ctrl.Value
End If
Next ctrl
End Sub
The code will go through each combobox on the form and copy the selected value to Sheet2 in the workbook.
Edit:
All the code incorporating the changes I made.
Sub addLabel()
UserForm6.Show vbModeless
Dim theLabel As Object
Dim ComboBox1 As Object
Dim CommandApp As Object
Dim CommandCan As Object
Dim buttonheight As Long
Dim fme As Frame
Dim c As Variant
Dim labelCounter As Long
Set fme = UserForm6.Frame1
For Each c In Sheets("Sheet1").Range("A1:A100")
If c.Value = "" Then Exit For
Set theLabel = fme.Add("Forms.label.1", "Test" & c, True)
With theLabel
.Caption = c
.Left = 10
.Width = 50
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 34
Else
.Top = 25 + (20 * (c.Row - 1)) + 9
End If
End With
Set ComboBox1 = fme.Controls.Add("Forms.combobox.1", "Test" & c, True)
With ComboBox1
.AddItem "Approved"
.AddItem "Partially Approved"
.AddItem "Not Approved"
.Left = 190
.Width = 120
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 30
Else
.Top = 30 + (20 * (c.Row - 1))
buttonheight = 30 + (20 * (c.Row - 1))
End If
End With
Next c
For Each c In Sheets("Sheet1").Range("B1:B100")
If c.Value = "" Then Exit For
Set theLabel = fme.Controls.Add("Forms.label.1", "Test" & c, True)
With theLabel
.Caption = c
.Left = 90
.Width = 70
.Height = 20
.Font.Size = 10
If c.Row = 1 Then
.Top = 34
Else
.Top = 25 + (20 * (c.Row - 1)) + 9
End If
End With
Next c
fme.ScrollHeight = buttonheight + 90
End Sub
I wonder if someone can help me please. I am a new VBA user and made a timesheet using guidelines on this website.
Currently, when the command button 2 is clicked, the data captured on the timesheet is transferred to sheet called 'Data' within the same worksheet. What I want is to transfer it to another workbook's sheet saved in another folder. Full path of sheet is C:\Users\mohskhan\Desktop\masterts.xlsm. Please can someone help.
Current coding is as follows:
Private Sub CommandButton2_Click()
ComboBox1.Enabled = True
Dim ssheet As Worksheet
Set ssheet = ThisWorkbook.Sheets("Data")
nr = ssheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
ssheet.Cells(nr, 1) = CDate(Me.TextBox1)
ssheet.Cells(nr, 2) = (Me.TextBox2)
ssheet.Cells(nr, 3) = (Me.ComboBox1)
ssheet.Cells(nr, 4) = (Me.ComboBox2)
ssheet.Cells(nr, 5) = (Me.TextBox3)
ssheet.Cells(nr, 6) = (Me.TextBox4)
ssheet.Cells(nr, 7) = (Me.TextBox5)
ssheet.Cells(nr, 8) = (Me.TextBox12)
ssheet.Cells(nr, 9) = (Me.ComboBox3)
ssheet.Cells(nr, 11) = Evaluate("=NOW()-TODAY()")
ssheet.Cells(nr, 14) = (Me.TextBox35)
ssheet.Cells(nr, 21) = (Me.TextBox6)
ssheet.Cells(nr, 22) = (Me.ComboBox4)
ssheet.Cells(nr, 23) = (Me.TextBox7)
ssheet.Cells(nr, 24) = (Me.TextBox23)
ssheet.Cells(nr, 25) = (Me.TextBox8)
ssheet.Cells(nr, 26) = (Me.ComboBox5)
ssheet.Cells(nr, 27) = (Me.TextBox9)
ssheet.Cells(nr, 28) = (Me.TextBox24)
ssheet.Cells(nr, 29) = (Me.TextBox10)
ssheet.Cells(nr, 30) = (Me.ComboBox6)
ssheet.Cells(nr, 31) = (Me.TextBox11)
ssheet.Cells(nr, 32) = (Me.TextBox25)
ssheet.Cells(nr, 34) = (Me.TextBox36)
ssheet.Cells(nr, 35) = (Me.TextBox37)
ComboBox1 = ""
ComboBox2 = ""
ComboBox3 = ""
TextBox3 = ""
TextBox4 = ""
TextBox12 = ""
TextBox5 = ""
ComboBox4 = ""
ComboBox5 = ""
ComboBox6 = ""
TextBox6 = ""
TextBox7 = ""
TextBox8 = ""
TextBox9 = ""
TextBox10 = ""
TextBox11 = ""
TextBox23 = ""
TextBox24 = ""
TextBox25 = ""
TextBox35 = ""
TextBox36 = ""
TextBox37 = ""
CommandButton1.Enabled = False
CommandButton2.Enabled = False
End Sub
Updated:
Private Sub CommandButton2_Click()
Const FullName = "C:\Users\Owner\Downloads\masterts.xlsm"
Dim CloseWorkbook As Boolean
Dim WB As Workbook
ComboBox1.Enabled = True
On Error Resume Next
Set WB = Workbooks("masterts.xlsm")
CloseWorkbook = Err.Number = 0
On Error GoTo 0
If WB Is Nothing Then Set WB = Workbooks.Open(FullName)
With WB.Worksheets("Data")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
.Resize(1, 13).Value = Array(CDbl(CDate(Me.TextBox1)), Me.TextBox2, Me.ComboBox1.Value, Me.ComboBox2.Value, Me.TextBox3.Value, Me.TextBox4.Value, _
Me.TextBox5.Value, Me.TextBox12.Value, Me.ComboBox3.Value, CDbl(TimeValue(Now)), Me.TextBox35.Value, Me.TextBox6.Value, Me.ComboBox4.Value)
End With
With .Range("U" & .Rows.Count).End(xlUp).Offset(1)
.Resize(1, 12).Value = Array(Me.TextBox7.Value, Me.TextBox23.Value, Me.TextBox8.Value, Me.ComboBox5.Value, Me.TextBox9.Value, Me.TextBox24.Value, Me.TextBox10.Value, Me.ComboBox6.Value, Me.TextBox11.Value, Me.TextBox25.Value, Me.TextBox36.Value, Me.TextBox37.Value)
End With
.Save
End With
If CloseWorkbook Then WB.Close SaveChanges:=False
CommandButton1.Enabled = False
CommandButton2.Enabled = False
End Sub
Should do the trick
Workbooks.Open("C:\Users\mohskhan\Desktop\masterts.xlsm")
Set ssheet = Workbooks("masterts.xlsm").Worksheets("Data")
'Run code
EDIT: I suggest turning off screen updating while you execute the data transfer
Application.ScreenUpdating = False
'Code to execute
Application.ScreenUpdating = True
I want to add many option button to an excel worksheet (not to a VBA-form) and want to group them by row. The result should look something like this:
Here is the code I'm using so far:
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d)))
Set checkboxJazCell = Range("J" + Trim(Str(d)))
groupWidth = checkboxKrankCell.Width + checkboxUrlaubCell.Width + checkboxJazCell.Width
Set groupBoxOptionButtons = ActiveSheet.GroupBoxes.Add(checkboxKrankCell.Left - 1, checkboxKrankCell.Top - 2, groupWidth + 1, checkboxKrankCell.Height)
With groupBoxOptionButtons
.Name = "GroupBox_" + Trim(Str(d))
.Caption = ""
End With
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
End With
#1 checkboxKrank.GroupBox = groupBoxOptionButtons
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
#2 .GroupBox = groupBoxOptionButtons
End With
Next d
I would expect to assign the option buttons to the group for the current row by setting the GroupBox property (see #1 or #2).
But both methods just gave me an error saying 'The object does not support the property or methode'.
Any help or hint is welcome ;-)
Based on the tip from snb I have modified my function like this:
Sub AddOptionButtons()
ActiveSheet.OptionButtons.Delete
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d + 4)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d + 4)))
Set checkboxJazCell = Range("J" + Trim(Str(d + 4)))
option1Name = "Krank_" + Trim(Str(d))
option2Name = "Urlaub_" + Trim(Str(d))
option3Name = "Jaz_" + Trim(Str(d))
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
.Name = option1Name
End With
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
.Name = option2Name
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
.Name = option3Name
End With
ActiveSheet.Shapes.Range(Array(option1Name, option2Name, option3Name)).Group
Next d
End Sub
I don't get any errors using Shapes.Range(...).Group.
But still all option buttons from on the sheet are all mutual exclusive.
Seems grouping does not work here.
Try the following code on an empty workbook. It will give you an option to choose only ONE optionbutton on each row, which is what you want, as far as I understood (I also created a linked cell reference, just in case you would like to take further action, given the choice of a user.):
Sub AddOptionButtons()
Dim btn1 As OptionButton
Dim btn2 As OptionButton
Dim btn3 As OptionButton
Dim grbox As GroupBox
Dim t As Range
Dim s As Range
Dim p As Range
Dim i As Integer
ActiveSheet.OptionButtons.Delete
ActiveSheet.GroupBoxes.Delete
For i = 5 To 35 Step 1
Set t = ActiveSheet.Range(Cells(i, 8), Cells(i, 8))
Set s = ActiveSheet.Range(Cells(i, 9), Cells(i, 9))
Set p = ActiveSheet.Range(Cells(i, 10), Cells(i, 10))
Set btn1 = ActiveSheet.OptionButtons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn2 = ActiveSheet.OptionButtons.Add(s.Left, s.Top, s.Width, s.Height)
Set btn3 = ActiveSheet.OptionButtons.Add(p.Left, p.Top, p.Width, p.Height)
Set grbox = ActiveSheet.GroupBoxes.Add(t.Left, t.Top, t.Width + 100, t.Height)
With btn1
.Caption = ""
.Display3DShading = True
.LinkedCell = "M" & i
End With
With btn2
.Caption = ""
.Display3DShading = True
End With
With btn3
.Caption = ""
.Display3DShading = True
End With
With grbox
.Caption = ""
.Visible = False
End With
Next i
End Sub
I'd use:
Sub M_snb()
ReDim sn(2)
For j = 1 To 2
For jj = 1 To 3
With Sheet1.OptionButtons.Add(Cells(j, jj).Left, Cells(j, jj).Top - 1, Cells(j, jj).Width, Cells(j, jj).Height)
sn(jj - 1) = .Name
End With
Next
Sheet1.Shapes.Range(sn).Group
Next
End Sub