Save userform checkbox selections to array (to replicate on userform) - arrays

How do I identify all the selected checkboxes in a frame in a user form and assign them to an array so that I can either/both: duplicate the selected checkboxes in one or more other frames & use the array to fill out spreadsheet cells?
Kind of a two-part question, but I think they go hand-in-hand (I'm not sure). I have a userform with multiple frames, and a lot of checkboxes inside each (SS) - I have a standard naming convention for all of them (explained bottom).
I will need to identify which checkboxes are selected (and the selection in the comboboxes) so I can put all that into a spreadsheet. I also will need the option for the user to copy all the selected checkboxes (and the selection in the comboboxes) from one frame to one to three of the other frames if s/he wants to. I have a "Copy" button that initializes a short userform to select which frame to copy from and which frame(s) to copy to. (For example: the ability to copy all the selections from the "Alpha Antennas" frame to one or more of "Beta Antennas" frame, "Gamma Antennas" frame, "Delta Antennas" frame.) Really stuck on what to do in the main form once I get that? I think one array will get me the two functions I need (copying one frame to another and filling out the spreadsheet) - but I don't know the next step. Any help?
Some code/naming/SS:
The command button that loads the main form:
Sub CreateADS()
Dim oneForm As Object
'==========================================================
'On Error GoTo ErrHandler 'Trying to catch errors - will input more down there, later
ADSinputform.Show
For Each oneForm In UserForms
Unload oneForm
'Unload ADSinputform
Next oneForm
End Sub
The main Userform beginning code:
Dim myCheckBoxes() As clsUFCheckBox
Private Sub UserForm_Activate()
'======================================================
'couple pre-initialization things here
'======================================================
End Sub
Private Sub UserForm_Initialize()
Dim chBox As Control
Dim comboBox As Control
Dim arrFreq() As String
Dim i As Long
Dim siteName As String
Dim ctrl As Object, pointer As Long
ReDim myCheckBoxes(1 To Me.Controls.Count)
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then
pointer = pointer + 1
Set myCheckBoxes(pointer) = New clsUFCheckBox
Set myCheckBoxes(pointer).aCheckBox = ctrl
End If
Next ctrl
ReDim Preserve myCheckBoxes(1 To pointer)
'Use the Split function to create two zero based one dimensional arrays.
arrFreq = Split("Unused|GSM,850|GSM,1900|UMTS,850|UMTS,1900|CDMA,850|LTE,700|LTE,850|LTE,1900|LTE,2100|LTE,2300", "|")
For Each comboBox In ADSinputform.Controls
If TypeOf comboBox Is MSForms.comboBox Then
For i = 0 To UBound(arrFreq)
'Use .List property to write array data to all the comboBoxes
comboBox.List = arrFreq
Next i
End If
Next
MsgBox "This pops up at the end of initialization"
End Sub
Private Sub cmdCopy_Click()
Dim chkBox As Control
Dim cmbBox As Control
Dim frmSource As MSForms.Frame
'Dim frmSource As String
Dim valSectCopy1 As String 'to validate that a sector is filled in
Dim valSectCopy2 As String 'to validate that an antenna is filled in
Dim valPortCopy As String 'to validate that a port is filled in
Set frmSource = SectorsFrame
valSectCopy1 = ""
valSectCopy2 = ""
valPortCopy = ""
For Each chkBox In frmSource.Controls 'Sector-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy1 = chkBox.Tag
valSectCopy2 = valSectCopy1
Set frmSource = Controls(valSectCopy1)
Exit For
End If
Next chkBox
If valSectCopy1 <> "" Then
For Each chkBox In frmSource.Controls 'Antenna-level frame
If TypeName(chkBox) = "CheckBox" And chkBox.Value = True Then
valSectCopy2 = chkBox.Tag
valPortCopy = valSectCopy2
Set frmSource = Controls(valSectCopy2)
Exit For
End If
Next chkBox
Else
GoTo NoSource
End If
If valSectCopy2 <> valSectCopy1 Then
For Each cmbBox In frmSource.Controls 'Port-level frame
If TypeName(cmbBox) = "ComboBox" And cmbBox.Value <> "Frequency" Then
valPortCopy = cmbBox.Value
Exit For
End If
Next cmbBox
Else
GoTo NoSource
End If
If valSectCopy2 = valPortCopy Then
GoTo NoSource
End If
CopySector.Show
If CopySector.destSectCopy <> "" And CopySector.srcSectCopy <> "" Then
MsgBox "Copying the " & CopySector.srcSectCopy & _
" sector to " & CopySector.destSectCopy & " sector(s)."
Unload CopySector
Exit Sub
Else
Exit Sub
End If
NoSource:
MsgBox "You have not filled in a sector to copy." & vbCrLf & _
"Please fill out sector info for at least one sector and try again."
Exit Sub
End Sub
The questionnaire userform code:
Public srcSectCopy As String
Public destSectCopy As String
Private Sub cmdCopy_Click()
Dim optBtn As Control
Dim chkBox As Control
srcSectCopy = ""
destSectCopy = ""
For Each optBtn In Me.Controls
If TypeName(optBtn) = "OptionButton" Then
If optBtn.Value = True Then
srcSectCopy = optBtn.Tag
End If
End If
Next optBtn
If srcSectCopy = "" Then
MsgBox "You have not selected a sector to copy." & vbCrLf & _
"Please select a sector to copy from and try again."
Exit Sub
End If
For Each chkBox In Me.Controls
If TypeName(chkBox) = "CheckBox" Then
If chkBox.Value = True Then
If destSectCopy = "" Then
destSectCopy = chkBox.Tag
Else
destSectCopy = destSectCopy & ", " & chkBox.Tag
End If
End If
End If
Next chkBox
If destSectCopy = "" Then
MsgBox "You have not selected any sectors to copy to." & vbCrLf & _
"Please select one or more sectors to be duplicated and try again."
Exit Sub
End If
Msg = "this will copy the " & srcSectCopy & _
" sector to " & destSectCopy & " sector(s)." & vbCrLf & _
"Do you want to continue with the operation?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_Initialize()
End Sub
Private Sub AlphaSect_OptBtn_Change()
Select Case (AlphaSect_OptBtn.Value)
Case True: AlphaSect_CheckBox.Enabled = False
AlphaSect_CheckBox.Value = False
Case False: AlphaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub BetaSect_OptBtn_Change()
Select Case (BetaSect_OptBtn.Value)
Case True: BetaSect_CheckBox.Enabled = False
BetaSect_CheckBox.Value = False
Case False: BetaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub GammaSect_OptBtn_Change()
Select Case (GammaSect_OptBtn.Value)
Case True: GammaSect_CheckBox.Enabled = False
GammaSect_CheckBox.Value = False
Case False: GammaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub DeltaSect_OptBtn_Change()
Select Case (DeltaSect_OptBtn.Value)
Case True: DeltaSect_CheckBox.Enabled = False
DeltaSect_CheckBox.Value = False
Case False: DeltaSect_CheckBox.Enabled = True
End Select
End Sub
Private Sub cmdCancel_Click()
Msg = "Are you sure you want to cancel and exit without copying?"
Ans = MsgBox(Msg, vbQuestion + vbYesNo)
Select Case Ans
Case vbYes
Me.Hide
Unload Me
Case vbNo
Exit Sub
End Select
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
' user clicked the X button
' cancel unloading the form, use close button procedure instead
Cancel = True
cmdCancel_Click
End If
End Sub
The following class:
Option Explicit
Public WithEvents aCheckBox As MSForms.CheckBox
Private Sub aCheckBox_Click()
Dim chBox As Control
Dim chBoxTag As String
chBoxTag = aCheckBox.Tag
If Right(aCheckBox.Parent.Name, 10) = "Port_Frame" Then
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Enabled = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Enabled = False
End If
Else
If aCheckBox.Value = True Then ADSinputform.Controls(chBoxTag).Visible = True
If aCheckBox.Value = False Then
ADSinputform.Controls(chBoxTag).Visible = False
For Each chBox In ADSinputform.Controls(chBoxTag).Controls
If TypeOf chBox Is MSForms.CheckBox Then chBox.Value = False
Next
End If
End If
End Sub
I'm not sure this can be done, and I'm not real sure where to even start with it. I know I can loop through all the controls and read the state or the combobox selection, but what to do after that?
Naming:
Frames: "AlphaSect_Frame", "BetaSect_Frame", "GammaSect_Frame"
First-Level Checkboxes: "A1Checkbox", "A2Checkbox", "A3Checkbox"... "B1Checkbox", "B2Checkbox"... "C1Checkbox", "C2Checkbox"
Second-Level Checkboxes: "A1P1Checkbox", "A1P2Checkbox", "A2P1Checkbox", "A2P2Checkbox"... "B1P1Checkbox", "B1P2Checkbox", "B2P1Checkbox", "B2P2Checkbox"... "C1P1Checkbox", "C1P2Checkbox", "C2P1Checkbox", "C2P2Checkbox"
Userform Screenshots:

Here's a simple example for a form with two frames, each of which has two checkboxes:
Dim f1 As Frame, f2 As Frame, c As Control
Set f1 = Me.Frame1 'has checkboxes "f1cb1", "f1cb2"
Set f2 = Me.Frame2 'has checkboxes "f2cb1", "f2cb2"
'loop over all controls in Frame 1
For Each c In f1.Controls
If TypeName(c) = "CheckBox" Then
'set the value of the corresponding control in the other fame
Me.Controls(Replace(c.Name, "f1", "f2")).Value = c.Value
End If
Next c

Related

Recipients(1) generates Error 440 array index out of bounds

I have Outlook VBA code that looks for a condition to match the exact subject and exact email address in one mailbox and then send a reply (Template) to the recipient of that email.
The script was working but lately is getting
Error 440 for array out of bounds.
When I debug it highlights the line:
Set pa = recips(1).PropertyAccessor"
The code is below.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objNewMailItems As Outlook.Items
'Update the AWS and Azure auto reply template path
Private Const AWS_AUTO_REPLY = "C:\Users\Documents\AWS_New_Account.oft"
Private Const AZURE_AUTO_REPLY = "C:\Users\Documents\Azure_New_Account.oft"
Private Sub Application_Startup()
Dim objMyInbox As Outlook.MAPIFolder
Dim oAccount As Account
Dim Store As Outlook.Store
'Set objNS = Application.GetNamespace("MAPI")
'For Each oAccount In Session.Accounts
' Set Store = oAccount.DeliveryStore
' Set objMyInbox = Store.GetDefaultFolder(olFolderInbox)
' Set objNewMailItems = objMyInbox.Items
' Set objMyInbox = Nothing
' MsgBox "Application_Startup"
'Next
Set objNS = Application.GetNamespace("MAPI")
Set objMyInbox = objNS.Folders("NewCloudAcct#xyz.com").Folders("Inbox")
Set objNewMailItems = objMyInbox.Items
Set objMyInbox = Nothing
MsgBox "Script Starting"
End Sub
Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
Dim subjectString As String
Dim senderEmailString As String
Dim recipientEmailString As String
Dim oRespond As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
'MsgBox "objNewMailItems_ItemAdd function call"
'Ensure we are only working with e-mail itemshe
If Item.Class <> olMail Then Exit Sub
subjectString = "" + Item.Subject
senderEmailString = "" + Item.SenderEmailAddress
'GetSMTPAddressForRecipients (Item)
recipientEmailString = ""
Set recips = Item.Recipients
'For Each recip In recips
Set pa = recips(1).PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
'Next
If (InStr(recipientEmailString, "naws") > 0) Or (InStr(recipientEmailString, "xaws") > 0) Or (InStr(recipientEmailString, "saws") > 0) Or (InStr(recipientEmailString, "vcaws") > 0) Or (InStr(recipientEmailString, "daws") > 0) Or (InStr(recipientEmailString, "vaws") > 0) Or (InStr(recipientEmailString, "rovisioningteam") > 0) Then
'MsgBox "D ACCOUNT - DO NOT SEND"
GoTo ENDOFCODE
End If
If InStr(subjectString, "Welcome to your Azure free account") > 0 Then
If InStr(senderEmailString, "azure-noreply#microsoft.com") > 0 Then
' This sends a response back using a template
' Enter the actual path for
Set oRespond = Application.CreateItemFromTemplate(AZURE_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("NewCloudAcct#xyz.com").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
' use this for testing, change to .send once you have it working as desired
'.Display
'.Send
End With
End If
End If
If InStr(subjectString, "[EXT] Welcome to Amazon Web Services") > 0 Then
If InStr(senderEmailString, "no-reply-aws#amazon.com") > 0 Then
' This sends a response back using a template
'MsgBox "AWS CONDITION"
Set oRespond = Application.CreateItemFromTemplate(AWS_AUTO_REPLY)
With oRespond
'.Recipients.Add Item.To
.Recipients.Add pa.GetProperty(PR_SMTP_ADDRESS)
.Recipients.Add("NewCloudAcct#xyz.com").Type = (olCC)
' includes the original message as an attachment
.Attachments.Add Item
'MsgBox "AWS CONDITION 2"
' use this for testing, change to .send once you have it working as desired
.Display
.Send
End With
End If
End If
ENDOFCODE:
Set oRespond = Nothing
End Sub
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
Function ResolveDisplayNameToSMTP(sFromName) As String
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
End Function
Sub Project1()
End Sub
You run into a message with no recipients, hence the line accessing the very first recipient fails.
recipientEmailString = ""
For Each recip In recips
Set pa = recip.PropertyAccessor
recipientEmailString = pa.GetProperty(PR_SMTP_ADDRESS) & ";" & recipientEmailString
Next
The ItemAdd event can be fired for items that are moved to the folder manually (or created from the ground and saved there). So, there is a chance the Recipients collection will be empty. In that case I'd recommend checking the Recipients.Count property first which returns a long indicating the count of objects in the specified collection.
Also you could use a low-level property which can help with distinguishing between read-only items - the PR_MESSAGE_FLAGS property contains a bitmask of flags that indicate the origin and current state of a message.
Finally, I'd suggest using the GetDefaultFolder method of the Namespace or Store class to retrieve the required folder instead of cryptic names, for example:
objNS.Folders("NewCloudAcct#xyz.com").Folders("Inbox")
If it is the default store you could use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Inbox folder for the user who is currently logged on. The Store.GetDefaultFolder method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.

Copy/Paste VBA Script Recorder Logs Wrong

A few issues: Script is linked to a form ctrl button that runs Update Data every minute. This runs Copy Data and copies row A39:T39 and pastes that row in the other sheet. That is the intent. But it doesn't paste right. Need to past in a row not a column starting w/ a time stamp on the other sheet in A2. Stop Recording Data is linked to a form ctrl button to cancel Update Data but that doesn't work either.
Sub UpdateData()
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End Sub
Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
logRng = sht2.Cells(2, Columns.Count).End(xlToLeft).Column + 1
sht2.Range("A2") = Now
cpyRng.Copy sht2.Cells(2, logRng)
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData", False
End Sub
Put this code into an own module.
To start logging, call StartRecordingData()
and for stopping call StopRecordingData()
Option Explicit
Dim boolLoggingActive As Boolean
Public Sub StartRecordingData()
Application.StatusBar = "Recording Dashboard Started"
boolLoggingActive = True
UpdateData
End Sub
Public Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
boolLoggingActive = False
End Sub
Private Sub UpdateData()
If boolLoggingActive = True Then
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End If
End Sub
Private Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
Dim rngLogTargetBeginningCell As Range
Set rngLogTargetBeginningCell = sht2.Rows(sht2.Rows.Count).Columns(1).End(xlUp).Offset(1, 0)
rngLogTargetBeginningCell = Now
Dim rngLastCellSelection As Range
Application.ScreenUpdating = False ' Stop Updating Graphic during data copy
Set rngLastCellSelection = Selection ' remember the last selection because pasting will change the active cell
cpyRng.Copy
rngLogTargetBeginningCell.Offset(0, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False ' Remove the copy area marker
rngLastCellSelection.Select ' reselect the old cell
Application.ScreenUpdating = True ' update graphics again
End Sub

How to write items from a ListBox into an Array VBA [duplicate]

I classify myself as a beginner in programing. I have a userform that first looks up a number presented by the user. Example 12345, 12346,12347. The number entered into the textbox is searched for and then added to the listbox as a valid number. After the user enters all the numbers needed, they should be able to click change and update the records accordingly.
Private Sub Change_Click()
Dim i As Long
For i = LBound(RunArray) To UBound(RunArray)
' Code to update each record, still working on it.
Next
End Sub
Private Sub RunNumber_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim RunArray() As String
Dim RunCount As Integer
RunCount = 0
If KeyCode = 13 Then
With Sheets("Sheet1").Range("A:A")
Set RunFind = .Find(What:=RunNumber, _
After:=.Cells(.Cells.count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not RunFind Is Nothing Then
ReDim Preserve RunArray(RunCount)
RunArray(RunCount) = RunNumber.Value
RunNumberList.AddItem RunNumber.Value
RunNumber.Value = ""
RunCount = RunCount + 1
Else
MsgBox "The Run Number you entered was not found, Please the number and try again."
RunNumber.Value = ""
End If
End With
End If
End Sub
Private Sub CreateArrayFromListbox()
Dim nIndex As Integer
Dim vArray() As Variant
' dimension the array first instead of using 'preserve' in the loop
ReDim vArray(ListBox1.ListCount - 1)
For nIndex = 0 To ListBox1.ListCount - 1
vArray(nIndex) = ListBox1.List(nIndex)
Next
End Sub
i have an example how to do it with a combobox, (it's the same with a listbox, just change the name accordingly.
Option Explicit
Private Sub UserForm_Initialize()
Dim i&
Dim Arr()
With Me.ComboBox1
For i = 1 To 1000
.AddItem "Item " & i
Next i
Arr = .List
.Clear
End With
For i = 0 To 999
Debug.Print Arr(i, 0)
Next i
Erase Arr
End Sub
this is just a sample code, in real coding, you won't clear the combobox this early, or erase the array.
The results are shown in the immediate window (alt-F11 , and Ctrl-g).
Note : the array is 2 dimendionned, and 0 based (Option base 1, after Option Explicitcan make the whole module 1-based (arrays start at 1) ).

VBA worksheet_change limited to single column doesn't respond to automatic updates

I am building a patient database. I have code that checks for changes in a specific column. if data in that column reaches a certain range, i make it send an email. Currently when i manually update the column the program works flawlessly, but when i have a date based formula update it - the macro doesn't seem to recognize it.
What could the problem be?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 22 Then Exit Sub
Dim rng As Range
For Each rng In Range("V1:V14")
If (rng.Value < 5 And rng.Value > 1) Then
Call mymacro(rng.Address)
End If
Next rng
End Sub
Private Sub mymacro(theValue As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"The patient that is due is in cell: " & theValue
On Error Resume Next
With xOutMail
.To = "email#hotmail.com"
.CC = ""
.BCC = ""
.Subject = "Upcoming Patient"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
the formula that updates the column is
=IF(P7<>"",(P7-TODAY()),"")

if array index is less than 0 then show message

The code below removes values and indexes from array. I am wondering on how to stop the code once the array index gets too less than 0. The code currently breaks at this point, and I am looking at ways on trying to handle this.
Dim ws As Worksheet
Dim cmbbox() As Variant 'or String
Private Sub btnUndo_Click()
Dim idx As Integer
'idx = UBound(cmbbox) - 1
If Not Len(Join(cmbbox, "")) = 0 Then 'if your array is not empty remove the last value from it
ReDim Preserve cmbbox(UBound(cmbbox) - 1)
'cmbbox(0) = cbDepartmentNotes.Value
'MsgBox (idx)
Else 'if your array is empty redim your array and add value from combobox
MsgBox ("Please select your note")
'ReDim Preserve cmbbox(UBound(cmbbox) + 1)
'cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub UserForm_Initialize()
Dim rngDepartment As Range
Set ws = Worksheets("Sheet1")
'Populate Department combo box.
For Each rngDepartment In ws.Range("Departments")
cbDepartment.AddItem rngDepartment.Value
Next rngDepartment
UserForm1.cbDepartmentNotes.Enabled = False
UserForm1.txtDepartmentNoteTemplate.Enabled = False
End Sub
Private Sub CommandButton1_Click() ' adds value to array and displays them in text box
If Len(Join(cmbbox, "")) = 0 Then 'if your array is empty add the first value from combobox to it
ReDim cmbbox(0)
cmbbox(0) = cbDepartmentNotes.Value
Else 'if your array is not empty redim your array and add value from combobox
ReDim Preserve cmbbox(UBound(cmbbox) + 1)
cmbbox(UBound(cmbbox)) = cbDepartmentNotes.Value
End If
'MsgBox "You selected Item : " & cmbbox(UBound(cmbbox))
'ListBox1.List = cmbbox
txtDepartmentNoteTemplate.Text = Join(cmbbox, ", ")
End Sub
Private Sub cbDepartment_Change() 'combo box value display function
displayNote
End Sub
Private Sub cbDepartmentNotes_Change()
txtDepartmentNoteTemplate.Enabled = True
End Sub
Function displayNote() As String
Dim rngDepartmentNote As Range
Dim x As String
Set ws = Worksheets("Sheet1")
If cbDepartment.Value = "IT" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "A"), Cells(3, "A").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
ElseIf cbDepartment.Value = "PST" Then
cbDepartmentNotes.Clear
For Each rngDepartmentNote In ws.Range(Cells(3, "B"), Cells(3, "B").End(xlDown))
cbDepartmentNotes.Enabled = True
cbDepartmentNotes.AddItem rngDepartmentNote.Value
txtDepartmentNoteTemplate.Enabled = True
x = cbDepartmentNotes.Value
displayNote = x
Next rngDepartmentNote
End If
End Function

Resources