Related
A strange question perhaps, but is there an alternative way of opening a workbook, searching for a particular reference in a column, and then pulling the data from a another column in that row using VBA, without using VLookup?
The table I am trying to get data from contains a mixture of numbers, text, dates, and the lookup value is often >13 digits long.
I sort of had something working with VLookup, but it was too inconsistent - every so often it would just break because the data type didn't match. An awful lot of 'type mismatch' or 'ByRef' errors - I'd get one right and then another breaks.
Unfortunately I don't know enough to know what to search to get me in the right direction.
If it helps explain what I'm trying to do, here's my code using VLookup that errors all the time:
Sub getData()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim wb As Workbook, src As Workbook
Dim srcRange As Range
Dim InputString
Dim strStatus
Dim strStatusNum
Dim strD1
Dim I As Integer
Set wb = ActiveWorkbook
I = 7
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While wb.ActiveSheet.Cells(I, 1) <> ""
'Makes sure src.Close is called if errors
'On Error Resume Next
InputString = wb.Worksheets("Sheet 1").Cells(I, 1)
strStatus = Application.VLookup(InputString, srcRange, 3, False)
strD1 = Application.VLookup(InputString, srcRange, 4, False)
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = Left(strStatus, 2)
wb.Worksheets("Sheet 1").Cells(I, 4) = strStatusNum
If (strStatusNum <> 3) Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "Not at 03. No Work Order"
ElseIf (strStatusNum = 3) And (strD1 <> "") Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "D1 Received"
wb.Worksheets("Sheet 1").Cells(I, 3) = strD1
Else
wb.Worksheets("Sheet 1").Cells(I, 2) = "No D1"
End If
I = I + 1
Loop
src.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
EDIT: Corrected some syntax.
You can use the Find method of the Range object, in your case of the column. The return value is the first cell (represented as another Range object) with a matching value, unless there is no match at all. Then Nothing is returned.
On the returned (single cell) range you can use the EntireRow method to get a Range that represents all the cells on the row of the found cell. On the returned (row) range you can use the Cells method to select the cell matching the column in the same row, that you want to return (again represented as another Range object).
By the way, a more flexible alternative to VLOOKUP in workbook functions is a combination of INDEX and MATCH.
Untested but compiled:
Sub getData()
Dim src As Workbook
Dim srcRange As Range
Dim strStatus, strStatusNum, strD1
Dim m, rw As Range
Set rw = ActiveSheet.Rows(7)
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While rw.Cells(1).Value <> ""
m = Application.Match(rw.Cells(1), srcRange.Columns(1), 0)
If Not IsError(m) Then 'proceed only if got match
strStatus = srcRange.Cells(m, 3).Value
strD1 = srcRange.Cells(m, 4).Value
strStatusNum = Left(strStatus, 2)
rw.Cells(4).Value = strStatusNum
If strStatusNum <> 3 Then
rw.Cells(2) = "Not at 03. No Work Order"
ElseIf strStatusNum = 3 And strD1 <> "" Then
rw.Cells(2) = "D1 Received"
rw.Cells(3) = strD1
Else
rw.Cells(2) = "No D1"
End If
End If
Set rw = rw.Offset(1, 0)
Loop
src.Close False
End Sub
you may be after this refactoring of your code
Sub getData()
Dim wbRng As Range, cell As Range, f As Range
Dim strStatus, strStatusNum, strD1
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
With ActiveWorkbook.ActiveSheet
Set wbRng = .Range("A7:A" & WorksheetFunction.Max(7, .Cells(.Rows.count, 1).End(xlUp).Row)) '<--| set the range of values to be searched for
If WorksheetFunction.CountA(wbRng) = 0 Then Exit Sub '<--| exit if no values under row 7
Set wbRng = wbRng.SpecialCells(xlCellTypeConstants) '<--| narrow the range of values to be searched for down to not blank values only
End With
With Workbooks.Open("D:\Files\test2.xlsx", True, True).Sheets(1) '<--| open wanted workbook and reference its first sheet
With .Range("A1:A" & .Cells(.Rows.count, "H").End(xlUp).Row) '<--| reference its column A range from row 1 down to column H last not empty cell (this is your former "srcRange")
For Each cell In wbRng.SpecialCells(xlCellTypeConstants) '<--| loop through range of values to be searched for
Set f = .Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look referenced range for current value to be searched for
If Not f Is Nothing Then '<--| if found
strStatus = f.Offset(, 2).Value
strD1 = f.Offset(, 3).Value
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = val(Left(strStatus, 2)) '<--| use 'Val()' function to convert string "03" to "3"
cell.Offset(, 3) = strStatusNum
Select Case True
Case strStatusNum <> 3
cell.Offset(, 1).Value = "Not at 03. No Work Order"
Case strStatusNum = 3 And (strD1 <> "")
cell.Offset(, 1).Resize(, 2).Value = Array("D1 Received", strD1)
Case Else
cell.Offset(, 1).Value = "No D1"
End Select
End If
Next
End With
.Parent.Close False
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
I am trying to add to the next empty cells to the right, the data from the user form text box, if data already exists. Meaning if "E1" is has date, add to "F1" and so on, but only is the range "E1:S1".
Here is a screenshot of the report:
And here is what I've got so far (but it stops as E1):
Private Sub CommandButton1_Click()
If Range("E1") = "" Then Range("E1") = UserForm2.TextBox1.Value Else
Range("E1").End(xlToRight) = UserForm2.TextBox1.Value
If Range("E2") = "" Then Range("E2") = UserForm2.TextBox2.Value Else
Range("E2").End(xlToRight) = UserForm2.TextBox2.Value
End Sub
The End(xlToRight is only going to the end of the populated cells not the next open one. You need to move one more column over after finding the last populated cell. Use Cells() and I prefere staring at the furthest column and coming back.
Private Sub CommandButton1_Click()
If Range("E1").Value = "" Then Range("E1").Value = UserForm2.TextBox1.Value Else
Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1).Value = UserForm2.TextBox1.Value
If Range("E2").Value = "" Then Range("E2").Value = UserForm2.TextBox2.Value Else
Cells(2, Cells(2, Columns.Count).End(xlToLeft).Column + 1).Value = UserForm2.TextBox2.Value
End Sub
I am trying to add a color-filling code into a worksheet_change private sub to highlight the cell where date value has been changed. This macro also updated the referenced database after any change has been made in date column (Column 1 or A). Here is the code:
Private Sub Worksheet_Change(ByVal Target As Range)
If strChk = "Don't Change Yet" Then Exit Sub
Dim r As Integer, c As Integer
r = Target.Row
c = Target.Column
If openMode = True Then Exit Sub
If Trim(Cells(Target.Row, 1)) = "" Then Exit Sub
If r = 2 Then Exit Sub
If r = 3 Then Exit Sub
If Not c = 1 Then Exit Su
If Not IsNumeric(Cells(Target.Row, 2)) Then
MsgBox "no orca number"
Exit Sub
End If
If Not IsDate(Cells(Target.Row, 1)) Then
MsgBox "Target date is invalid! Weird, right?"
Exit Sub
End If
Dim strsqla As String
strsqla = "select target_date, orca, cow from orca " & _
"where orca_id = " & Cells(Target.Row, 2)
Dim adoSQLcon As ADODB.Connection
Set adoSQLcon = New ADODB.Connection
adoSQLcon.Open "Provider=SQLOLEDB;Persist Security Info=False;Integrated Security=SSPI;Initial Catalog=ENV_AC_Nording_dw_DEV;Data Source=S0662K806"
Dim adoSQLRst As ADODB.Recordset
Set adoSQLRst = New ADODB.Recordset
adoSQLRst.Open strsqla, adoSQLcon, adOpenStatic, adLockOptimistic
If adoSQLRst.RecordCount > 0 Then
If IsDate(Target.Value) Then
adoSQLRst!target_date = Cells(Target.Row, 1).Value
MsgBox "Date Updated"
End If
If Not Cells(Target.Row, 4).Value = "" Then
adoSQLRst!ORCA = Cells(Target.Row, 4).Value
MsgBox "ORCA Description Updated"
End If
If Not Cells(Target.Row, 8).Value = "" Then
adoSQLRst!COW = Cells(Target.Row, 8).Value
MsgBox "CoW Devices Updated"
End If
adoSQLRst.Update
End If
adoSQLRst.Close
Set adoSQLRst = Nothing
adoSQLcon.Close
Set adoSQLcon = Nothing
Cells(Target.Row, 1).Interior.Color = RGB(255, 255, 0)
End Sub
So the code I added is "Cells(Target.Row, 1).Interior.Color = RGB(255, 255, 0)". So I want to highlight the cell after changed. But it ended up with this Run-time error '1004':Application-defined or object-defined error. So I was wondering if anyone could help me with this. Cuz I have tried all different types of color-filling codes I can find from website but all of them generated this error.
Thank you very much for any help could provide.
First replace:
If Not c = 1 Then Exit Su
with
If Not c = 1 Then Exit Sub
There may be other problems.
try to use Cells(Target.Range.Row, 1).Interior.Color = RGB(255, 255, 0)
I am not sure it will work but this is how I used it in my own script.
I'm still a Noob when it comes to VBA, but I'm gradually picking it up as I go along. I need help trying to get my simple Flexitime input form to log flexi time "taken" as negative time (-01:00) on a spreadsheet, but I'm not sure how to go about doing it.
This is what I've got so far:
Private Sub submit_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim irow As Long
Set wb = FlexBook
Set ws = FlexBook.Worksheets("Flex Data")
irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If Trim(Me.employee.Value) = "" Then
Me.employee.SetFocus
MsgBox "Please select a name"
Exit Sub
End If
If Trim(Me.owta.Value) = "" Then
Me.owta.SetFocus
MsgBox "Please select whether it is time taken or time owed"
Exit Sub
End If
If Trim(Me.Time.Value) = "" Then
Me.Time.SetFocus
MsgBox "Please input the amount of time"
Exit Sub
End If
If Trim(Me.dateflex.Value) = "" Then
Me.dateflex.SetFocus
MsgBox "Please input the date the flex was owed or taken"
Exit Sub
End If
If Trim(Me.author.Value) = "" Then
Me.author.SetFocus
MsgBox "Please confirm who has authorised this"
Exit Sub
End If
If Trim(Me.owta.Value) = "Owed" Then
Time = Time
ElseIf Trim(Me.owta.Value) = "Taken" Then
Time = Time * -1
Exit Sub
End If
'Insert data in to the table
ws.Cells(irow, 1).Value = Me.employee.Value
ws.Cells(irow, 2).Value = Me.owta.Value
'ws.Cells(irow, 3).Value = ? <---cell to indicate positive or negative time
ws.Cells(irow, 4).Value = CDate(Me.dateflex.Value)
ws.Cells(irow, 5).Value = Me.author.Value
'clear the data
Me.employee.Value = ""
Me.owta.Value = ""
Me.Time.Value = ""
Me.dateflex.Value = ""
Me.author.Value = ""
Me.employee.SetFocus
End Sub
You could use an instant If, an If block, or a Select Case - your choice:
ws.Cells(irow, 3).Value = IIf(Trim(Me.owta.Value) = "Owed", "+", "-")
'// However I wouldn't advise this if you want to evaluate "Owed" and "Taken" seperately.
or
If Trim(Me.owta.Value) = "Owed" Then
ws.Cells(irow, 3).Value = "+"
ElseIf Trim(Me.owta.Value) = "Taken" Then
ws.Cells(irow, 3).Value = "-"
End If
or
Select Case Trim(Me.owta.Value)
Case "Owed": ws.Cells(irow, 3).Value = "+"
Case "Taken": ws.Cells(irow, 3).Value = "-"
End Select
All have their own pros and cons, but in the context in which you are using them will show little difference.
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