After I click the command button, I want my excel to do:
Input what I type in text boxes / select in combo boxes in specific columns without deleting the one I previously entered
But at this moment, it does not work as I expected or enter any of input from text boxes and combo boxes.
The script I wrote is:
Private Sub
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then
If MsgBox ("There might one or more empty cells,
do you want to continue to proceed?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Dim invsheet As Worksheet
Dim pacsheet As Worksheet
Set invsheet = ThisWorkbook.Sheets("INV")
Set pacsheet = ThisWorkbook.Sheets("PAC")
invsheet.Range("A1").Value = TextBox6.Text
invsheet.Range("I5").Value = TextBox7.Text
invsheet.Range("A21").Value = TextBox5.Text
invsheet.Range("A25").Value = ComboBox1.Value
inv_nr = invsheet.Cells(Row.Count, 1).End(xlUp).Row +1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
pac_nr = pacsheet.Cells(Row.Count, 1).End(xlUp).Row +1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox3
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox4
Problem:
inv_nr = invsheet.Cells(Row.Count, 1).End(xlUp).Row +1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
pac_nr = pacsheet.Cells(Row.Count, 1).End(xlUp).Row +1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2
pacsheet.Cells(pac_nr, 7).Value = Me.TextBox3 'mistyped it. supposed to be 7
pacsheet.Cells(pac_nr, 9).Value = Me.TextBox4 'mistyped it. supposed to be 9
This block of code does not work and create any output on the worksheet.
I will really appreciate your help.
Thank you!
You're not placing anything in column A (except A1, A21, and A25 of invsheet), so it's not a good idea to set your inv_nr and pac_nr variables based on the last used cell in column A.
Try basing it on one of the columns you are populating with data, e.g. column 5:
'Always qualify "Rows" (and don't mistype it as "Row")
inv_nr = invsheet.Cells(invsheet.Rows.Count, 5).End(xlUp).Row + 1
invsheet.Cells(inv_nr, 5).Value = Me.TextBox1
invsheet.Cells(inv_nr, 4).Value = Me.ComboBox2
'Always qualify "Rows" (and don't mistype it as "Row")
pac_nr = pacsheet.Cells(pacsheet.Rows.Count, 5).End(xlUp).Row + 1
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox2 'Note: This is pointless because the next line overwrites it
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox3 'Note: This is pointless because the next line overwrites it
pacsheet.Cells(pac_nr, 5).Value = Me.TextBox4
I'm trying to read a CSV with VBA. When following this tutorial, I get the following code:
Sub OpenTextFile()
Dim FilePath As String
FilePath = "C:\path\to\file\mycsv.csv"
Open FilePath For Input As #1
row_number = 0
Do Until EOF(1)
Line Input #1, LineFromFile
LineItems = Split(LineFromLine, ",")
ActiveCell.Offset(row_number, 0).Value = LineItems(2)
ActiveCell.Offset(row_number, 1).Value = LineItems(1)
ActiveCell.Offset(row_number, 2).Value = LineItems(0)
row_number = row_number + 1
Loop
Close #1
End Sub
This is my CSV:
peter,paris,23
mary,london,34
steve,rome,56
lily,madrid,65
When executing the code, I get an error:
Index out of range
And this line is marked yellow:
ActiveCell.Offset(row_number, 0).Value = LineItems(2)
You have a typo:
LineItems = Split(LineFromLine, ",")
should be
LineItems = Split(LineFromFile, ",")
This would not have happened if you used Option Explicit at the beginning of your module ;)
Can someone please confirm why my macro jumps out of loop. I am not getting why its happening.
My Input looks like this http://i.imgur.com/Y6XRBai.jpg
What I am trying is split the text and write to textfile from column D2 onwards using while loop, First file writes properly but when it starts writing second file either for loop or if condition breaks out and macro comes to line where strDir starts
Sub SplitTextAndSave()
'Macro to split text and write to text file
'Full name of File name will be Single quote + Prefix from B2 + ( + filename from C2 + )'
'Application.DisplayAlerts = False
Dim Val, splitVal As String
Dim reqNumTxt, totLn, reqNum, remChr, i As Integer
Dim wb As Workbook
Dim strFile, fileNm, strDir As String
Set Sheet = Excel.ActiveSheet
' Select where to place the files
Dim obj As Object
Dim path As String
Set obj = CreateObject("Shell.Application").browseforfolder(0, "Please Select Folder where TWS scripts will be created", 0)
On Error GoTo error_trap:
path = obj.self.path & "\"
error_trap:
'this is where it starts again when the loop breaks
strDir = path
filepre = Sheet.Cells(2, 2).Value
reqNum = Sheet.Cells(3, 2).Value
reqNumTxt = 0
Sheet.Cells(2, 4).Activate
Do While ActiveCell.Value <> ""
Set nextcell = ActiveCell.Offset(1, 0)
fileNm = ActiveCell.Offset(0, -1).Value
FileFullNm = strDir & "'" & filepre & "(" & fileNm & ")'"
Open FileFullNm For Output As #1
Val = ActiveCell.Value
totLn = Int(Len(Val) / reqNum)
remChr = Len(Val) Mod reqNum
If Len(Val) <= reqNum Then
Print #1, Val
Close #1
Else
For i = 1 To totLn
'I observed sometimes loop breaks here
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
reqNumTxt = reqNumTxt + reqNum
Next i
If remChr = 0 Then
Close #1
Else
'most of the time loop break here when writing second file
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
Close #1
End If
End If
nextcell.Select
Set currentcell = nextcell
'Next
Loop
MsgBox "Done"
'Application.DisplayAlerts = True
End Sub
I added 2 lines to your code and it runs without error. I set splitVal to null and reqNumTxt to zero.
Val = ActiveCell.Value
totLn = Int(Len(Val) / reqNum)
remChr = Len(Val) Mod reqNum
**splitVal = ""**
If Len(Val) <= reqNum Then
Print #1, Val
Close #1
Else
For i = 1 To totLn
'I observed sometimes loop breaks here
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
reqNumTxt = reqNumTxt + reqNum
Next i
If remChr = 0 Then
Close #1
Else
'most of the time loop break here when writing second file
splitVal = Left(Right(Val, Len(Val) - reqNumTxt), reqNum)
Print #1, splitVal
Close #1
End If
End If
nextcell.Select
Set currentcell = nextcell
**reqNumTxt = 0**
Loop
I have the following issue. I have several source file to copy from into my summary sheet (the order of columns/rows can differ). Thus, I am trying to do some hard-coded check with a h/v-lookup combo. The code is the following:
For i = 2 To Row_number
'''' 1150 ''''
If (Cells(i, 42).Value = "1150") Then
If (WB_1150 Is Nothing) Then
Set WB_1150 = Workbooks.Open(directory & file_1150)
For Each wb In Workbooks
If (wb <> ThisWorkbook & wb <> WB_1150) Then
wb.Close savechanges = False
End If
Next wb
End If
bool_vlookup_result = IsError(Application.vlookup(ThisWorkbook.Sheets(sheet_name_swaption).Cells(i, 12), WB_1150.Sheets(1).range("V1:V" & Row_number), 1, False))
If (bool_vlookup_result = True) Then
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "ERROR"
Next i
Else
row_index_result = Application.Match(Cells(i, 2), WB_1150.Sheets(1).range("V1:V" & Row_number), 0)
For j = 1 To 42
If (Cells(row_index_result, j) = "") Then
Next j
Else
bool_hlookup_result = IsError(Application.HLookup(ThisWorkbook.Sheets(sheet_name_swaption).Cells(i, j), WB_1150.Sheets(1).range(Cells(row_index_result, 1), Cells(row_index_result, 22)), 1, False))
If (bool_hlookup_result = True) Then
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "ERROR"
Next i
End If
End If
Next j
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "OK"
End If
End If
'''' End 1150 ''''
''' OTHER SOURCE FILES '''
Next i
I get the error Next without For, because as soon as I got an error I can skip to the following i/j. Any suggestions to solve/improve this? I know that there can be several ways to do those checks, but this is the most powerful (and most time-consuming though) instrument that I found. Many thanks in advance.
You can do it in such way:
For i = 1 To 10
If i = 3 Then GoTo Cont
Debug.Print i
Cont:
Next i
Hi I have the following code to search and the searched items are displayed in the listbox. I also have an update button that updates whatever new information you input in a textbox. the update box works fine but for some reason when multiple duplicated items are displayed in the listbox and i try to click the 2nd instance and try to update, it updates the original and not the 2nd instance. So, the first instance should update first instance item, and 2nd should update 2nd but right now, 1st is updating 1st instance, 2nd is updating 1st instance, 3rd is updating 1st instance - always updating the 1st instance. how can i fix this? this is the document: https://www.dropbox.com/s/36e9fmbf17wpa0l/example.xlsm
Public Sub Search_Click()
Dim Name As String
Dim f As Range
Dim s As Integer
Dim FirstAddress As String
Dim str() As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Master")
Name = surname.Value
With ws
Set f = .Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
SetCheckBoxes f.Offset(0, 5) '<<< replaces code below
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
r = f.Row
End With
findnext
FirstAddress = f.Address
Do
s = s + 1
Set f = Range("A:A").findnext(f)
Loop While Not f Is Nothing And f.Address <> FirstAddress
If s > 1 Then
Select Case MsgBox("There are " & s & " instances of " & Name, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries")
Case vbOK
findnext
Case vbCancel
End Select
End If
Else: MsgBox Name & "Not Listed"
End If
End With
End Sub
'-----------------------------------------------------------------------------
Sub findnext()
Dim Name As String
Dim f As Range
Dim ws As Worksheet
Dim s As Integer
Dim findnext As Range
Name = surname.Value
Me.ListBox1.Clear
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
Set findnext = f
With ListBox1
Do
Debug.Print findnext.Address
Set findnext = Range("A:A").findnext(findnext)
.AddItem findnext.Value
.List(.ListCount - 1, 1) = findnext.Offset(0, 1).Value
.List(.ListCount - 1, 2) = findnext.Offset(0, 2).Value
.List(.ListCount - 1, 3) = findnext.Offset(0, 3).Value
.List(.ListCount - 1, 4) = findnext.Offset(0, 4).Value
.List(.ListCount - 1, 5) = findnext.Offset(0, 5).Value
.List(.ListCount - 1, 6) = findnext.Offset(0, 6).Value
.List(.ListCount - 1, 7) = findnext.Offset(0, 7).Value
.List(.ListCount - 1, 8) = findnext.Offset(0, 8).Value
Loop While findnext.Address <> f.Address
End With
End With
End Sub
'----------------------------------------------------------------------------
Public Sub update_Click()
MsgBox "Directorate has been updated!"
Dim Name As String
Dim f As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
f.Value = surname.Value
f.Offset(0, 1).Value = firstname.Value
f.Offset(0, 2).Value = tod.Value
f.Offset(0, 3).Value = program.Value
f.Offset(0, 4).Value = email.Value
f.Offset(0, 5).Value = GetCheckBoxes
f.Offset(0, 6).Value = officenumber.Value
f.Offset(0, 7).Value = cellnumber.Value
End With
End Sub
The first obvious problem is r. This global is used as a temporary variable by Search_Click and as a master variable by update_Click.
Consider update_Click. Near the beginning we have:
Set ws = ThisWorkbook.Worksheets("Master")
With ws
Set f = .Cells(r, 1)
If you load the form, fill the fields and click Update then r will not have been initialised so with have the default value of zero.
It is very difficult to guess what this form is attempting to achieve. Most of the buttons do nothing. Of the two buttons that do work, neither is documented. I appreciate this form is under development but, if you are going to ask people to help debug it, you should make it easier to do so.
I assume the objective of update_Click is to add a new row to the bottom of worksheet "Master". If this assumption is true then I suggest the following:
Public Sub update_Click()
MsgBox "Directorate has been updated!"
Dim RowNext As Long
With ThisWorkbook.Worksheets("Master")
' There is no checking of the values entered by the user.
' I have assumed that the surname is present on the last used row.
' If this assumption is untrue, the new data will overwrite the row
' below the last row with a surname.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(RowNext, "A").Value = surname.Value
.Cells(RowNext, "B").Value = firstname.Value
.Cells(RowNext, "C").Value = tod.Value
.Cells(RowNext, "D").Value = program.Value
.Cells(RowNext, "E").Value = email.Value
.Cells(RowNext, "F").Value = GetCheckBoxes
.Cells(RowNext, "G").Value = officenumber.Value
.Cells(RowNext, "H").Value = cellnumber.Value
End With
End Sub
If you confirm that I am on the right track, I have a look at Search_Click.
The code below is substantial different from yours. Partly this is because your code did not work while, to the extent I have tested it, mine does. But most of the changes are because I did not understand your code. As I worked through your code, I documented it, changed to meaningful names and implemented the effects I thought you were trying to achieve.
When you are creating code, it is important to remember that in six or twelve months you will be back to update it for new requirements. A little time spent making the code easy to understand as you write it can save hours when you need to maintain it. Name variables systematically so you immediately know what they are when you return. Explain what each subroutine and block of code it attempting to achieve so you can find the code you wish to update.
Firstly I have changed your form. I have made the form a little deeper and moved the listbox down. Above the listbox I have inserted a label which I have named lblMessage. This label spans the entire width of the form and is three lines deep. Most of your text is Tahoma 8. This label is Tahoma 10 and is coloured blue. I use it to tell the user what they are expected to do.
As the first line of the form's code I have added:
Option Explicit
Look this statement up to see why it should always be present.
You use Offsets to access the various columns in the worksheet. This can be a nightmare if the columns are every re-arranged. I have used constants:
Const ColMasterFamilyName As String = "A"
Const ColMasterGivenName As String = "B"
Const ColMasterTitle As String = "C"
Const ColMasterProgArea As String = "D"
Const ColMasterEMail As String = "E"
Const ColMasterStakeHolder As String = "F"
Const ColMasterOfficePhone As String = "G"
Const ColMasterCellPhone As String = "H"
This makes my statements much longer than yours but means that instead of 5, say, I have a name.
These constants are named using my system. "Col" says these are columns. "Master" says which worksheet they apply to. "FamilyName" says which column. In your code you use "surname" and "first name". I worked for too many years in an area where "surname" and "first name" were not "culturally sensitive". I am not asking you to like my system but you must have a system. I can look at code I wrote years ago and know what the variables are.
I have replaced your:
Public r As Long
with:
Dim RowEnteredName() As Long
I redimension this array for every select. If only a single row matches the entered name then it is dimensioned as ReDim RowEnteredName(1 To 1) and RowEnteredName(1) holds the row number. If Count rows match the entered name then it is dimensioned as ReDim RowEnteredName(0 To Count). RowEnteredName(0) is not used because it corresponds to the heading line while RowEnteredName(1 To Count) hold the row numbers for each repeat of the name.
I have added a form initialisation routine to prepare the form for use.
I have recoded your findnext as FillListBox because you cannot use keywords as the name for subroutines or variables.
There are routines in your code that I have commented out so that I know the code below is complete.
I hope all this makes sense.
Option Explicit
Const ColMasterFamilyName As String = "A"
Const ColMasterGivenName As String = "B"
Const ColMasterTitle As String = "C"
Const ColMasterProgArea As String = "D"
Const ColMasterEMail As String = "E"
Const ColMasterStakeHolder As String = "F"
Const ColMasterOfficePhone As String = "G"
Const ColMasterCellPhone As String = "H"
Dim RowEnteredName() As Long
Private Sub ListBox1_Click()
'pop listbox when more than one instances are prompted
'cliking the person's name will change the textboxes
'transfer the values to updateclick
Dim RowMasterCrnt As Long
If ListBox1.ListIndex = 0 Then
'Debug.Assert False
lblMessage.Caption = "You cannot select the heading row. Please select a person."
Exit Sub
End If
With ThisWorkbook.Worksheets("Master")
RowMasterCrnt = RowEnteredName(ListBox1.ListIndex)
ReDim RowEnteredName(1 To 1)
RowEnteredName(1) = RowMasterCrnt
surname.Value = .Cells(RowMasterCrnt, ColMasterFamilyName).Value
firstname.Value = .Cells(RowMasterCrnt, ColMasterGivenName).Value
tod.Value = .Cells(RowMasterCrnt, ColMasterTitle).Value
program.Value = .Cells(RowMasterCrnt, ColMasterProgArea).Value
email.Value = .Cells(RowMasterCrnt, ColMasterEMail).Value
Call SetCheckBoxes(.Cells(RowMasterCrnt, ColMasterStakeHolder).Value)
officenumber.Value = .Cells(RowMasterCrnt, ColMasterOfficePhone).Value
cellnumber.Value = .Cells(RowMasterCrnt, ColMasterCellPhone).Value
lblMessage.Caption = "Please change details as required then click [Update]. " & _
"If you have selected the wrong person, " & _
"please click [Select] to reselect."
update.Visible = True
End With
ListBox1.Visible = False ' Cannot use again because RowEnteredName changed
End Sub
Private Sub Search_Click()
' User should have entered a Family name before clicking Search.
If surname.Value = "" Then
Debug.Assert False ' Not tested
lblMessage.Caption = "Please enter a Family name or Surname"
Exit Sub
End If
Dim Name As String
Dim CellNameFirst As Range ' First cell, if any, holding family name
Dim Count As Long
Dim FirstAddress As String
lblMessage.Caption = ""
Name = surname.Value
With ThisWorkbook.Worksheets("Master")
' Look for entered family name in appropriate column
Set CellNameFirst = .Columns(ColMasterFamilyName).Find( _
what:=Name, after:=.Range(ColMasterFamilyName & "1"), _
lookat:=xlWhole, LookIn:=xlValues, _
SearchDirection:=xlNext, MatchCase:=False)
If Not CellNameFirst Is Nothing Then
' There is at least one person with the entered family name.
' Fill the listbox and make it visible if there is more than one person
' with the entered family name
'Debug.Assert False ' Not tested
Call FillListBox(CellNameFirst)
If ListBox1.Visible Then
' There is more than one person with the entered name
' Ensure update not available until selection made from list box
'Debug.Assert False ' Not tested
update.Visible = False
lblMessage.Caption = "Please click the required person within the listbox"
Exit Sub
Else
' Only one person with entered name
' Prepare the entry controls for updating by the user
'Debug.Assert False ' Not tested
ReDim RowEnteredName(1 To 1)
RowEnteredName(1) = CellNameFirst.Row ' Record row for selected family name
firstname.Value = .Cells(RowEnteredName(1), ColMasterGivenName).Value
tod.Value = .Cells(RowEnteredName(1), ColMasterTitle).Value
program.Value = .Cells(RowEnteredName(1), ColMasterProgArea).Value
email.Value = .Cells(RowEnteredName(1), ColMasterEMail).Value
Call SetCheckBoxes(.Cells(RowEnteredName(1), ColMasterStakeHolder).Value)
officenumber.Value = .Cells(RowEnteredName(1), ColMasterOfficePhone).Value
cellnumber.Value = .Cells(RowEnteredName(1), ColMasterCellPhone).Value
lblMessage.Caption = "Please change details as required then click Update"
update.Visible = True
End If
Else
Debug.Assert False ' Not tested
lblMessage.Caption = "No person found with that name. Please try another."
update.Visible = False
End If
End With
End Sub
Public Sub update_Click()
With ThisWorkbook.Worksheets("Master")
.Cells(RowEnteredName(1), "A").Value = surname.Value
.Cells(RowEnteredName(1), "B").Value = firstname.Value
.Cells(RowEnteredName(1), "C").Value = tod.Value
.Cells(RowEnteredName(1), "D").Value = program.Value
.Cells(RowEnteredName(1), "E").Value = email.Value
.Cells(RowEnteredName(1), "F").Value = GetCheckBoxes
.Cells(RowEnteredName(1), "G").Value = officenumber.Value
.Cells(RowEnteredName(1), "H").Value = cellnumber.Value
End With
' Clear controls ready for next select and update
surname.Value = ""
firstname.Value = ""
tod.Value = ""
program.Value = ""
email.Value = ""
Call SetCheckBoxes("")
officenumber.Value = ""
cellnumber.Value = ""
lblMessage.Caption = "Please enter the family name or surname of the " & _
"person whose details are to be updated then " & _
"click [Search]."
update.Visible = False
End Sub
Private Sub UserForm_Initialize()
' Set controls visible or invisible on initial entry to form.
' Update is not available until Search has been clicked and current
' details of a single person has been displayed.
update.Visible = False
' The listbox is only used if Search finds the entered name matches
' two or more people
ListBox1.Visible = False
' Search is the first button to be clicked and is always available
' as a means of cancelling the previous selection.
Search.Visible = True
' Not yet implemented
CommandButton1.Visible = False
CommandButton2.Visible = False
CommandButton3.Visible = False
CommandButton7.Visible = False
lblMessage.Caption = "Please enter the family name or surname of the " & _
"person whose details are to be updated then " & _
"click [Search]."
End Sub
Function ColCodeToNum(ColStg As String) As Integer
' Convert 1 or 2 character column identifiers to number.
' A -> 1; Z -> 26: AA -> 27; and so on
Dim lcColStg As String
lcColStg = LCase(ColStg)
ColCodeToNum = IIf(Len(ColStg) > 1, (Asc(Left(ColStg, 1)) - 64) * 26, 0) + _
Asc(Right(ColStg, 1)) - 64
End Function
Sub FillListBox(CellNameFirst As Range)
' CellNamefirst is the first, possibly only, cell for the
' family name entered by the user.
' Clear the listbox. If there is more than one person with the
' entered family name, make the listbox visible and fill it with
' every person with the same family name
Dim CellName As Range
Dim Count As Long
Dim ListBoxData() As String
Dim RowMasterCrnt As Long
Dim LbEntryCrnt As Long
Me.ListBox1.Clear
Set CellName = CellNameFirst
' Count number of rows with same family name as CellNameFirst
Count = 1
With ThisWorkbook.Worksheets("Master")
Do While True
Set CellName = .Columns(ColMasterFamilyName).findnext(CellName)
If CellName.Row = CellNameFirst.Row Then
'Debug.Assert False
Exit Do
End If
'Debug.Assert False
Count = Count + 1
Loop
End With
If Count = 1 Then
' Only one person has the entered family name
'Debug.Assert False
Me.ListBox1.Visible = False
Exit Sub
End If
'Debug.Assert False
Set CellName = CellNameFirst
ReDim ListBoxData(1 To 8, 0 To Count) ' Row 0 used for column headings
ReDim RowEnteredName(0 To Count)
LbEntryCrnt = 0
With ThisWorkbook.Worksheets("Master")
' Create column headings
ListBoxData(ColCodeToNum(ColMasterFamilyName), LbEntryCrnt) = _
.Cells(2, ColMasterFamilyName).Value
ListBoxData(ColCodeToNum(ColMasterGivenName), LbEntryCrnt) = _
.Cells(2, ColMasterGivenName).Value
ListBoxData(ColCodeToNum(ColMasterTitle), LbEntryCrnt) = _
.Cells(2, ColMasterTitle).Value
ListBoxData(ColCodeToNum(ColMasterProgArea), LbEntryCrnt) = _
.Cells(2, ColMasterProgArea).Value
ListBoxData(ColCodeToNum(ColMasterEMail), LbEntryCrnt) = _
.Cells(2, ColMasterEMail).Value
ListBoxData(ColCodeToNum(ColMasterStakeHolder), LbEntryCrnt) = _
.Cells(2, ColMasterStakeHolder).Value
ListBoxData(ColCodeToNum(ColMasterOfficePhone), LbEntryCrnt) = _
.Cells(2, ColMasterOfficePhone).Value
ListBoxData(ColCodeToNum(ColMasterCellPhone), LbEntryCrnt) = _
.Cells(2, ColMasterCellPhone).Value
LbEntryCrnt = LbEntryCrnt + 1
Do While True
' For each row with the same family name, add details to array
RowMasterCrnt = CellName.Row
ListBoxData(ColCodeToNum(ColMasterFamilyName), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterFamilyName).Value
ListBoxData(ColCodeToNum(ColMasterGivenName), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterGivenName).Value
ListBoxData(ColCodeToNum(ColMasterTitle), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterTitle).Value
ListBoxData(ColCodeToNum(ColMasterProgArea), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterProgArea).Value
ListBoxData(ColCodeToNum(ColMasterEMail), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterEMail).Value
ListBoxData(ColCodeToNum(ColMasterStakeHolder), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterStakeHolder).Value
ListBoxData(ColCodeToNum(ColMasterOfficePhone), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterOfficePhone).Value
ListBoxData(ColCodeToNum(ColMasterCellPhone), LbEntryCrnt) = _
.Cells(RowMasterCrnt, ColMasterCellPhone).Value
RowEnteredName(LbEntryCrnt) = RowMasterCrnt
LbEntryCrnt = LbEntryCrnt + 1
Set CellName = .Columns(ColMasterFamilyName).findnext(CellName)
If CellName.Row = CellNameFirst.Row Then
Exit Do
End If
Loop
End With
Me.ListBox1.Column = ListBoxData ' Write array to listbox
ListBox1.Visible = True
End Sub
'Get the checked checkboxes as a space-separated string
Function GetCheckBoxes() As String
Dim arrStakeHolderAll() As Variant
Dim i As Long
Dim rv As String
'Debug.Assert False
arrStakeHolderAll = WhatCheckboxes()
rv = ""
For i = LBound(arrStakeHolderAll) To UBound(arrStakeHolderAll)
'Debug.Assert False
If Me.Controls(arrStakeHolderAll(i)).Value = True Then
'Debug.Assert False
rv = rv & IIf(Len(rv) > 0, " ", "") & arrStakeHolderAll(i)
End If
Next i
GetCheckBoxes = rv
End Function
Sub SetCheckBoxes(strList As String)
' Populate checkboxes from space-separated values in strList.
' Pass "" to just clear checkboxes
Dim arrStakeHolderAll() As Variant
Dim arrStakeHolderCrnt() As String
Dim i As Long
Dim tmp As String
'Debug.Assert False
PACT.Value = False
PrinceRupert.Value = False
WPM.Value = False
Montreal.Value = False
TET.Value = False
TC.Value = False
US.Value = False
Other.Value = False
arrStakeHolderAll = WhatCheckboxes()
If Len(strList) > 0 Then
'Debug.Assert False
arrStakeHolderCrnt = Split(strList, " ")
For i = LBound(arrStakeHolderCrnt) To UBound(arrStakeHolderCrnt)
'Debug.Assert False
tmp = Trim(arrStakeHolderCrnt(i))
If Not IsError(Application.Match(tmp, arrStakeHolderAll, 0)) Then
'Debug.Assert False
Me.Controls(tmp).Value = True
End If
Next i
End If
End Sub
'returns the name of all Stakeholder checkboxes
Function WhatCheckboxes() As Variant()
'Debug.Assert False
WhatCheckboxes = Array("PACT", "PrinceRupert", "WPM", _
"Montreal", "TET", "TC", "US", "Other")
End Function