Userform works despite Run-Time Error 91. What's going on? - excel

I am new to Userforms. I have created the following Userform which is called from a subroutine. The Userform picks up a range from a sheet and creates a corresponding number of textboxes and then checkboxes so as to allocate an original name with a new name.
The userform is created with the following:
Public Sub UserForm_Initialize()
'Declare variables
Dim txtBox As MSForms.TextBox
Dim comBox As MSForms.ComboBox
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim dist As Integer
Dim dstArr As Variant
Dim rng As Range
'Assign variables
Set rng = Range("Missing_MAERSK")
n = rng.Rows.Count
dist = 5
dstArr = Range("LU_Destination_Ports").Value
'Loop to add textboxes
For i = 1 To n
Set txtBox = UserForm1.Controls.Add("Forms.TextBox.1", Visible:=True)
With txtBox
.name = "txtBox" & i
.Value = rng(i)
.Height = 20
.Width = 150
.Left = 81
.Top = 30 + dist
.Font.Size = 10
End With
dist = dist + 20
Next i
'Loop to add list boxes
dist = 5
For j = 1 To n
Set comBox = UserForm1.Controls.Add("Forms.ComboBox.1", Visible:=True)
With comBox
.name = "comBox" & j
.List = dstArr
.Height = 20
.Width = 150
.Left = 315
.Top = 30 + dist
.Font.Size = 10
End With
dist = dist + 20
Next j
'Show userform
UserForm1.Show
End Sub
And then when the Replace Names button is clicked the following is ran:
Public Sub CommandButton1_Click()
'Close userform
Unload UserForm1
'This is the one
Dim cmb As MSForms.ComboBox
' Dim txt As MSForms.TextBox
Dim oldVal As String
Dim newVal As String
Dim rng As Range
Dim rng2 As Range
Dim n As Integer
Set rng = Range("MAERSK_Destin")
Set rng2 = Range("Missing_MAERSK")
n = rng2.Rows.Count
'Loop
For i = 1 To n
Set txt = Me.Controls("txtBox" & i)
Set cmb = Me.Controls("comBox" & i)
If cmb.Value <> "" Then
oldVal = txt.Value
newVal = cmb.Value
rng.Replace what:=oldVal, Replacement:=newVal
End If
Next i
End Sub
Let's say I populate Bangkok to Bangkok BMT, I get the following:
I think the issue might be with the way I call the values in the Command_Button1_Click sub.
Any advice would be appreciated.
Cheers

Figured out the problem.
According to this post: Call UserForm_Initialize from Module
a UserForm should not be initialized from outside the userform.
I was calling UserForm_Initialize() from my sub, so to rectify this I replaced it with UserForm1.Show

Related

How to insert a picture from an existing table with file path and desired placement

I'm trying to create the following template:
The user creates a table in a "Data Entry" worksheet that lists the following:
File path ie: P:\Phone Camera Dump\20121224_111617.jpg
Range where the picture is to be placed in the "PICS" worksheet.
Once the list is finalized, the user executes and images are placed within the ranges specified on the "PICS" worksheet and dynamically re-sized.
Presently the range has a set width of 624px and a height of 374px, but ideally, I would like the image to resize (aspect ratio not locked) dynamically in the width and height change.
I've used the following code as a base but am struggling with how to incorporate the cell ranges instead of the static row updates:
Sub InsertSeveralImages()
Dim pic_Path As String 'File path of the picture
Dim cl As Range, Rng As Range
Dim WS_Templte As Worksheet
Set WS_Templte = Worksheets("PICS")
Set Rng = Worksheets("Data Entry").Range("C13:C42")
pastingRow = 2
For Each cl In Rng
pic_Path = cl.Value
Set InsertingPicture = WS_Templte.Pictures.Insert(pic_Path)
'Setting of the picture
With InsertingPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 100
.Top = WS_Templte.Rows(pastingRow).Top
.Left = WS_Templte.Columns(3).Left
End With
pastingRow = pastingRow + 5
Next cl
Set myPicture = Nothing
WS_Templte.Activate
End Sub
Any thoughts?
I figured it out. Here is the code in case anyone wants to use it:
Public Sub InsertPictures()
Dim vntFilePath As Variant
Dim rngFilePath As Range
Dim vntPastePath As Variant
Dim rngPastePath As Range
Dim lngCounter As Long
Dim pic As Picture
Set WS_Templte = Worksheets("PICS")
On Error GoTo ErrHandler
With ThisWorkbook.Sheets("PICS") '<-- Change sheet name accordingly
' Set first cell containing a row number
Set rngFilePath = .Range("BJ7")
vntFilePath = rngFilePath.Value
' Set first cell containing a paste range
Set rngPastePath = .Range("BK7")
vntPastePath = rngPastePath.Value
Do Until IsEmpty(vntFilePath)
If Dir(vntFilePath) = "" Then vntFilePath = strNOT_FOUND_PATH
Set pic = .Pictures.Insert(vntFilePath)
lngCounter = lngCounter + 1
With pic
.ShapeRange.LockAspectRatio = msoFalse
If .ShapeRange.Rotation = 90! Or .ShapeRange.Rotation = 270! Then
.Height = Application.CentimetersToPoints(16.3)
.Width = Application.CentimetersToPoints(10.03)
.Top = WS_Templte.Rows(rngPastePath).Top - (.Height - .Width) / 2#
.Left = WS_Templte.Columns(4).Left + (.Height - .Width) / 2#
Else
.Width = Application.CentimetersToPoints(10.03)
.Height = Application.CentimetersToPoints(16.3)
.Top = WS_Templte.Rows(rngPastePath).Top
.Left = WS_Templte.Columns(4).Left
End If
End With
Set rngFilePath = rngFilePath.Offset(1)
vntFilePath = rngFilePath.Value
Set rngPastePath = rngPastePath.Offset(1)
vntPastePath = rngPastePath.Value
Loop
End With
MsgBox lngCounter & " pictures were inserted.", vbInformation
ExitProc:
Set rngFilePath = Nothing
Set pic = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub

VBA how to Create Multi Select ListBoxes in qualifying cells

I am trying to achieve code where multi-select ListBoxes are added if Column 4 or 5 are selected and Column 2 in the same row has the string "has options".
The Listboxes contain values from named ranges called "option1" and "option2". Current Selections are output to the respective cell in Column 4 or 5 separated by commas.
This is the code I have in "This Workbook" object. It needs to work on all sheets.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 4 And Target.OFFSET(0, -1).Value = "has options" Then
CreateOpt1PopUp Target
End If
If Target.Column = 5 And Target.OFFSET(0, -2).Value = "has options" Then
CreateOpt2PopUp Target
End If
Else
DeleteAllOpt1PopUps Target
DeleteAllOpt2PopUps Target
End If
End If
End Sub
This is the code I have in a Module. The criteria has evolved and therefore I have amended the code multiple times to the point where it no longer works.
Private opt1SelectCell As Range
Public Function Opt1Area(ByRef ws As Worksheet) As Range
Const OPT1_COL As Long = 4
Dim lastOpt1Row As Long
With ws
lastOpt1Row = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
If lastOpt1Row = 0 Then
Set Opt1Area = Nothing
Else
Set Opt1Area = .Cells(2, OPT1_COL).Resize(lastOpt1Row, 1)
End If
End With
End Function
Public Sub Opt1BoxClick()
Dim opt1BoxName As String
opt1BoxName = Application.Caller
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes(opt1BoxName)
Dim opt1List As String
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.Selected(i) Then
opt1List = opt1List & opt1Box.List(i) & ","
End If
Next i
If Len(opt1List) > 0 Then
opt1List = Left$(opt1List, Len(opt1List) - 1)
End If
opt1SelectCell.Value = opt1List
End Sub
Public Function Opt1ListArea() As Range
Set Opt1ListArea = ActiveSheet.Range("option1")
End Function
Public Sub DeleteAllOpt1PopUps(ByRef selectedCell As Range)
Dim opt1Box As ListBox
For Each opt1Box In selectedCell.Parent.ListBoxes
opt1Box.Delete
Next opt1Box
End Sub
Public Sub CreateOpt1PopUp(ByRef selectedCell As Range)
Set opt1SelectCell = selectedCell
Dim Opt1PopUpCell As Range
Set Opt1PopUpCell = opt1SelectCell.OFFSET(1, 0)
DeleteAllOpt1PopUps selectedCell
'--- now create listbox
Const OPT1_POPUP_WIDTH As Double = 75
Const OPT1_POPUP_HEIGHT As Double = 110
Const OPT1_OFFSET As Double = 5#
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes.Add(Opt1PopUpCell.Left + OPT1_OFFSET, _
Opt1PopUpCell.Top + OPT1_OFFSET, _
OPT1_POPUP_WIDTH, _
OPT1_POPUP_HEIGHT)
With opt1Box
.ListFillRange = Opt1ListArea().Address(external:=True)
.LinkedCell = ""
.MultiSelect = xlSimple
.Display3DShading = True
.OnAction = "Module1.Opt1BoxClick"
End With
'--- is there an existing list of options selected?
Dim selectedOptions1() As String
selectedOptions1 = Split(opt1SelectCell.Value, ",")
Dim opt1 As Variant
For Each opt1 In selectedOptions1
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.List(i) = opt1 Then
opt1Box.Selected(i) = True
Exit For
End If
Next i
Next opt1
End Sub
This is an example of the excel data.
How can I make this work and even improve it?

Get and write a value to a sheet from a textbox created dynamically in a UserForm

I have a UserForm composed of a TextBox and a CommandButton.
By entering a value in the TextBox, for example 3, and clicking the CommandButton, I create three new TextBox with labels linked to each one of them. It also creates just under those TextBox and Labels another CommandButton.
I write in each new TextBox a value. For example in the first TextBox I write "Banana", in the second "Apple" and so on.
I want by clicking the new CommandButton, to get the value from the new TextBoxes and write them in a sheet.
How do I get the value from these new TextBoxes considering they are created during the runtine.
Here is the code linked to my UserForm:
Option Explicit
Dim cmdArray() As New Classe1
Public Sub nbEquipButtonValidation_Click()
Dim i As Variant
Dim Nb_equip As Integer
Dim j As Long
Nb_equip = UserForm1.nbEquipTextBox.Value
For i = 1 To Nb_equip
Dim EquipLabel
Dim Text_Boxes
Dim CmdBtn
Set EquipLabel = Me.Controls.Add("Forms.Label.1")
With EquipLabel
.Top = 25 + 10 * i * 2
.Left = 10
.Caption = "Equipement n°" & CStr(i)
.Name = "Equip" & CStr(i)
End With
Set Text_Boxes = Me.Controls.Add("Forms.TextBox.1", True)
With Text_Boxes
.Top = 20 + 10 * i * 2.1
.Left = 100
.Name = "Text_Box" & CStr(i)
End With
Next i
Set CmdBtn = Me.Controls.Add("Forms.CommandButton.1")
With CmdBtn
.Top = 20 + 10 * Nb_equip * 2.1 + 30
.Left = 75
.Caption = "Créer"
.Name = "Validation"
End With
' Apply a class to the new Button
j = 1
ReDim Preserve cmdArray(1 To j)
Set cmdArray(j).CmdEvents = CmdBtn
Set CmdBtn = Nothing
End Sub
Here is the class I created to get these data and write them in a sheet by clicking the second CommandButton.
Option Explicit
Public WithEvents CmdEvents As MSForms.CommandButton
Private Sub CmdEvents_Click()
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Dim i As Variant
Dim Nb_equip As Integer
Nb_equip = UserForm1.nbEquipTextBox.Value
For i = 1 To Nb_equip
With Ws
.Cells(6, 2 + i * 2).Value = "Exp" & CStr(i)
End With
Next i
End Sub
In my loop I want to replace "Exp" & CStr(i) by the name of the value in the TextBox according to the position i of creation.
This should work:
Modify your class to add a reference to the Form object:
Option Explicit
Public WithEvents CmdEvents As MSForms.CommandButton
Public frm As Object '<<<<<<<<<<<
Private Sub CmdEvents_Click()
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Dim i As Variant
Dim Nb_equip As Integer
Nb_equip = frm.nbEquipTextBox.Value
For i = 1 To Nb_equip
Ws.Cells(6, 2 + i * 2).Value = frm.Controls("Exp" & CStr(i)).Text
Next i
End Sub
Then add the line below:
Set cmdArray(j).CmdEvents = CmdBtn
Set cmdArray(j).frm = Me '<<<<<<<<

Add Textboxes to Userform Frame based on a Cell Value

I want a user to press a button to pull all their "Open" positions into a userform.
I have a Userform with a Frame and a command button to search through Column 3 (named "Status") on a spreadsheet and find the word "Open". Once this word is found I want textboxes to be automatically created inside the frame with the data from the "found" row for columns 4 - 10.
So if one row is found with "Open" then I expect 7 textboxes to be created on the userform. From the picture below I expect 28 textboxes.
When I press the command button nothing happens - no errors - nothing. I tried to use the breakpoints to troubleshoot but nothing was revealed to me to take action on. I am not "seeing" why it is not working here.
I tried moving the code outside the userform and into a module and calling the function but that didn't do anything.
I tried setting the rows I want as constants and creating a separate "AddBox" function to call within the main code but that didn't work but I also didn't understand that code as much as I do the one I am posting now.
Frame Name = Open_Positions_Frame
Command Button Name = open_post_but
Sheet Name = Database
Public Sub open_post_but_Click() '*****The command Button on the userform Frame*****
Dim i As Integer ' for the loop
Dim wb As Workbook
Dim wk As Worksheet
Dim ctlTextBox As MSForms.TextBox
Dim intCol, intCols As Integer '******for the columns I want to pull into the userform*****
Dim strCName As String '******this is to name the textboxes******
Dim lastRow As Long
Dim curColumn As Long
Set wb = ThisWorkbook
Set wk = wb.Sheets("Database")
curColumn = 3 '*********column index here - Mine starts at Column 3 ********
lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
For i = 3 To lastRow 'Loop through row 3 to last row
'********If the text "Open" is found in a row in column 3 then
' add & fill textboxes with data from Columns 4-10 onto the userform frame******
If wk.Cells(i, 3) = "Open" Then
'******Add the textboxes***********
'*****Columns 4-10 add textbox and give the control a name C# - #is the column*****
For intCol = 4 To intCols = 10
strCName = "C" & intCol
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1", strCName)
With ctlTextBox
.Top = 10
.width = 50
.height = 20
.Left = (intCol) * 60
.Value = intCol
End With
Next
'********************************
End If
Next i
End Sub
UPDATED and TESTED
You were writing the text boxes on top of each other. i added a separater by row.
Public Sub open_post_but_Click()
'you might want to experiment with these.
Const curColumn As Long = 4 'index will start a column 4 "Status"
Const theWidth As Long = 66 'you might experiment with these
Const theRowDifference As Long = 20
Dim i As Long, intCol As Long, rowspacer As Long
Dim ctlTextBox As MSForms.TextBox
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wk As Worksheet: Set wk = wb.Sheets("Database")
Dim lastRow As Long: lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
For i = 3 To lastRow
For Each cl In wk.Cells(3, curColumn)
If InStr(1, cl.Value, "Open", vbTextCompare) > 0 Then
rowspacer = rowspacer + theRowDifference
'******Add the textboxes***********
For intCol = 5 To 11
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1")
With ctlTextBox
.Top = rowspacer
.width = theWidth
.height = 20
.Left = intCol * 60
.Name = "openPosBox" & intCol
.Value = wk.Cells(i, intCol).Value
End With
Next intCol
'********************************
End If
Next cl
Next i
End Sub
PGSystemTester helped figure out the stacking textbox issues - Huge thank you! However, I was still struggling with my If Condition statement. I managed to figure it out and I am adding the complete code as an answer for anyone needing this use case
Public Sub open_post_but_Click()
Const curColumn As Long = 4 'index will start a column 4 "Status"
Const theWidth As Long = 70 'you might experiment with these
Const theRowDifference As Long = 20
Dim i As Long, intCol As Long, rowspacer As Long
Dim ctlTextBox As MSForms.TextBox
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wk As Worksheet: Set wk = wb.Sheets("Database")
Dim lastRow As Long: lastRow = wk.Cells(Rows.Count, curColumn).End(xlUp).row
Dim status As String
status = "Open"
For i = 3 To lastRow
If Cells(i, curColumn).Value = status Then 'took on the Instr() function and added this instead, textboxes will only be created if the column 4 status is "Open"
rowspacer = rowspacer + theRowDifference
'******Add the textboxes***********
For intCol = 4 To 11
Set ctlTextBox = Open_Positions_Frame.Controls.Add("Forms.Textbox.1")
With ctlTextBox
.Top = rowspacer
.width = theWidth
.height = 20
.Left = intCol * 40
.Name = "openPosBox" & intCol
.Value = wk.Cells(i, intCol).Value
End With
Next intCol
'********************************
End If
Next i
End Sub

How to rename active-x Control textboxes that are grouped with shape after copying and pasting to another worksheet

I am putting together a Bar Bending Schedule for the Building Industry. I am new to excel vba and am doing my best but have stumbled across a problem that I am struggling to find a solution to.
I am working with the following objects in my project;
Worksheet "BBS"
Worksheet "Shapes"
Userform "BBSForm"
I have shapes grouped with textboxes on the "Shapes" worksheet. Example shape is "L" which is an L-shaped Bar with 2 dimensions and hence 2 textboxes.
When the "L" shape is chosen on the userform and textbox dimensions are entered I click a button that submits the entry to the "BBS" worksheet. It copies the "Lgroup" from the shapes sheet and pastes it into the "BBS" sheet.
The problem occurs when I have 2 textboxes as once pasted they change name and I need to know their names so I can populate them with the dimensions.
I have the code below so far but the L shape doesn't work as "Forms.TextBox.2" doesn't exist, both textboxes in the group are "Forms.TextBox.1".
Sub ShapeSelectCopy()
Dim CodeSh As String
CodeSh = BBSForm.TextBoxShp.Value
Worksheets("BBS").Activate
Range("A1").End(xlDown).Offset(0, 5).Select
Dim nextsh As Range
Set nextsh = Selection
Select Case CodeSh
Case "S"
Sheets("Shapes").Select
ActiveSheet.Shapes.Range(Array("Group 13")).Select
Selection.Copy
Sheets("BBS").Select
ActiveSheet.Paste
Dim newname As String
newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
Selection.Name = newname
With Selection
.Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
.Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
End With
Dim shpG As Shape, shp As Shape
Dim objOLE As OLEObject
Set shpG = ActiveSheet.Shapes(newname)
For Each shp In shpG.GroupItems
Set objOLE = shp.OLEFormat.Object
If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
Next
Case "L"
Sheets("Shapes").Select
ActiveSheet.Shapes.Range(Array("Group 12")).Select
Selection.Copy
Sheets("BBS").Select
ActiveSheet.Paste
Dim newname As String
newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
Selection.Name = newname
With Selection
.Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
.Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
End With
Dim shpG As Shape, shp As Shape
Dim objOLE As OLEObject
Set shpG = ActiveSheet.Shapes(newname)
For Each shp In shpG.GroupItems
Set objOLE = shp.OLEFormat.Object
If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
If objOLE.progID = "Forms.TextBox.2" Then objOLE.Object.Value = BBSForm.TextBoxB.Value
Next
End Select
End Sub
Any Help would be greatly appreciated.
Factoring out some of the repeated code here's one approach:
Sub ShapeSelectCopy()
Dim CodeSh As String
Dim nextsh As Range
Dim shtShapes As Worksheet, shtBBS As Worksheet
Dim shpToCopy As String, val1, val2
Dim tbCount As Long
Dim shpG As ShapeRange, shp As Shape, pid
Set shtShapes = Worksheets("Shapes")
Set shtBBS = Worksheets("BBS")
Set nextsh = shtBBS.Range("A1").End(xlDown).Offset(0, 5)
shpToCopy = ""
CodeSh = BBSForm.TextBoxShp.Value
Select Case CodeSh
Case "S"
shpToCopy = "Group 13"
val1 = BBSForm.TextBoxA.Value
val2 = ""
Case "L"
shpToCopy = "Group 12"
val1 = BBSForm.TextBoxA.Value
val2 = BBSForm.TextBoxB.Value '<< edit to fix typo
End Select
If shpToCopy = "" Then Exit Sub 'exit if no shape to copy
'copy the shape
shtShapes.Shapes(shpToCopy).Copy
shtBBS.Activate
shtBBS.Paste
Set shpG = Selection.ShapeRange
'name and position
With shpG
.Name = shtBBS.Range("A1").End(xlDown).Value
.Left = nextsh.Left + (nextsh.Width - shpG.Width) / 2
.Top = nextsh.Top + (nextsh.Height - shpG.Height) / 2
End With
'populate textbox(es)
tbCount = 0
For Each shp In shpG.GroupItems
On Error Resume Next
pid = shp.OLEFormat.progID
On Error GoTo 0
'Debug.Print ">>>", pid
If pid = "Forms.TextBox.1" Then
tbCount = tbCount + 1
If tbCount = 1 Then shp.OLEFormat.Object.Object.Value = val1
If tbCount = 2 Then shp.OLEFormat.Object.Object.Value = val2
End If
Next shp
End Sub

Resources