Option Explicit
Dim AlignLeft As Boolean
Dim objCtrl As Control
Dim iPtr As Integer
Dim cNum As Integer
Dim x As Integer
Dim i As Integer
Dim mrCurrentCell As Range
Dim msaWorksheets() As String
Dim msFirstAddress As String
Dim NextRow As Long
Dim mvaSearchResults() As Variant
Dim mvaSearchHeadings() As Variant
Dim mwsSearchResults As Worksheet
Private Sub UserForm_Initialize()
Dim lWSPtr As Long
Dim lWSCount As Long
Dim sCurWS As String
CheckSize
lWSCount = 0
ReDim msaWorksheets(1 To 1)
For lWSPtr = 1 To ThisWorkbook.Sheets.Count
sCurWS = ThisWorkbook.Sheets(lWSPtr).Name
If sCurWS <> "Search" And sCurWS <> "SearchResults" Then
lWSCount = lWSCount + 1
ReDim Preserve msaWorksheets(1 To lWSCount)
msaWorksheets(lWSCount) = sCurWS
End If
Next lWSPtr
Set mrCurrentCell = Nothing
btnSearch.Enabled = False
lblresults.Caption = ""
With lbs
cbContactType.List = Array("Council Contacts", "Local Contacts", "Housing Associations", "Landlords", "Letting and Selling Agents", "Developers", "Employers")
lblOrganisationName.Visible = False
txt1.Visible = False
lblContactName.Visible = False
txt2.Visible = False
lblTelephoneNumber.Visible = False
txt3.Visible = False
lblEmailAddress.Visible = False
txt4.Visible = False
lblPostalAddress.Visible = False
txt5.Visible = False
lblPassword.Visible = False
txt6.Visible = False
cmdbReset.Enabled = False
cmdbUpdate.Enabled = False
cmdbNew.Enabled = False
cmdbChange.Enabled = False
cmdbDelete.Enabled = False
MLA.Visible = False
mstrAccounts.Visible = False
mstrNo.Value = True
txt7.Visible = False
lbs.Visible = False
' lbs.ColumnCount = 7
lbs.ColumnCount = 8
lbs.ColumnHeads = True
lbs.ColumnWidths = "135 pt;142 pt;135 pt;135 pt;135 pt;135 pt;135 pt;135 pt"
lb.Visible = False
lb.ColumnCount = 7
lb.ColumnHeads = True
lb.ColumnWidths = "135 pt;142 pt;135 pt;135 pt;135 pt;135 pt;135 pt;135 pt"
For Each objCtrl In Me.Controls
If Left(objCtrl.Name, 4) = "Text" Then txt7.Visible = False
Next
If txt7.Value = "" Then
txt7.Value = "Example1: " & vbCrLf & "Example2: " & vbCrLf & "Example3: "
End If
End With
' 'Create Headers
' .Range("A1").Value = "#"
' .Range("B1").Value = "Company Name"
' .Range("C1").Value = "Contact Name"
' .Range("D1").Value = "Telephone Number"
' .Range("E1").Value = "Password"
' .Range("F1").Value = "E-mail Address"
' .Range("G1").Value = "Postal Address"
' .Range("H1").Value = "Worksheet"
ReDim mvaSearchHeadings(1 To 8, 1 To 1)
mvaSearchHeadings(1, 1) = "#"
mvaSearchHeadings(2, 1) = "Company Name"
mvaSearchHeadings(3, 1) = "Contact Name"
mvaSearchHeadings(4, 1) = "Telephone Number"
mvaSearchHeadings(5, 1) = "Password"
mvaSearchHeadings(6, 1) = "E-mail Address"
mvaSearchHeadings(7, 1) = "Postal Address"
mvaSearchHeadings(8, 1) = "Worksheet"
On Error Resume Next
Set mwsSearchResults = Nothing
Set mwsSearchResults = Sheets("SearchResults")
If mwsSearchResults Is Nothing Then
Set mwsSearchResults = Worksheets.Add(after:=ActiveSheet)
With mwsSearchResults
.Name = "SearchResults"
.Visible = xlSheetHidden
End With
End If
On Error GoTo 0
With mwsSearchResults
.Cells.Clear
.Range("A1").Resize(, UBound(mvaSearchHeadings, 1)).Value = WorksheetFunction.Transpose(mvaSearchHeadings)
End With
End Sub
Private Sub iptSearch_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
btnSearch_Click
End If
End Sub
Private Sub CheckSize()
Dim h, w
Dim c As Control
h = 0: w = 0
For Each c In Me.Controls
If c.Visible Then
If c.Top + c.Height > h Then h = c.Top + c.Height
If c.Left + c.Width > w Then w = c.Left + c.Width
End If
Next c
If h > 0 And w > 0 Then
With Me
.Width = w + 10
.Height = h + 10
End With
End If
End Sub
Private Sub btnSearch_Click()
Dim ip As Integer, r As Integer
Dim sCurName As String
Dim WS As Worksheet, WSnew As Worksheet
Dim lrow As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
Worksheets.Add
Set WSnew = ActiveSheet
r = 1
For ip = 1 To UBound(msaWorksheets)
Set WS = Sheets(msaWorksheets(ip))
Set mrCurrentCell = WS.Cells.Find(what:=iptSearch.Value, LookIn:=xlValues, lookat:=xlPart)
If Not (mrCurrentCell Is Nothing) Then
msFirstAddress = mrCurrentCell.Address
Do
r = r + 1
Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
mrCurrentCell.EntireRow.Copy
WSnew.Paste Destination:=Cells(r, 1)
WSnew.Cells(r, 8).Value = mrCurrentCell.Worksheet.Name
Loop While Not mrCurrentCell Is Nothing And mrCurrentCell.Address <> msFirstAddress
End If
Next ip
With WSnew
If r < 2 Then
MsgBox prompt:="Cannot find '" & iptSearch.Value & "'", _
Buttons:=vbOKOnly + vbInformation, _
Title:="Text not found"
Else
'Create Headers
.Range("A1").Value = "#"
.Range("B1").Value = "Company Name"
.Range("C1").Value = "Contact Name"
.Range("D1").Value = "Telephone Number"
.Range("E1").Value = "Password"
.Range("F1").Value = "E-mail Address"
.Range("G1").Value = "Postal Address"
.Range("H1").Value = "Worksheet"
.Range("A2").Value = 1
If r > 2 Then .Range("A2").AutoFill Destination:=.Range("A2:A" & r), Type:=xlLinearTrend
'populate listbox
With Me.lbs
.Visible = True
.ColumnCount = 8
.ColumnWidths = "15 pt;142 pt;135 pt;135 pt;135 pt;135 pt;135 pt;85 pt"
.ColumnHeads = False
.List = WSnew.Range("A1:H" & r).Value
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub
Private Sub iptSearch_Change()
Dim lPointer As Long
Dim lStartPointer As Long
Dim lPtr As Long
Dim lFoundCount As Long
Dim lColumnPointer As Long
Dim lResultsColPtr As Long
Dim rResultsRange As Range
Dim sCurName As String
Dim sCurHeading As String
Dim sCurrentFoundAddress As String
Dim vaResults As Variant
Dim vaDataLine As Variant
Dim vaHeadingLine As Variant
Dim WS As Worksheet
Set mrCurrentCell = Nothing
lStartPointer = 1
lblresults.Caption = ""
lFoundCount = -1
If iptSearch.Text <> "" Then
' ReDim vaResults(0 To 1, 0 To 0)
ReDim mvaSearchResults(1 To UBound(mvaSearchHeadings, 1), 1 To 1)
For lPointer = lStartPointer To UBound(msaWorksheets)
msFirstAddress = ""
Set WS = Sheets(msaWorksheets(lPointer))
vaHeadingLine = Intersect(WS.Rows(1), WS.UsedRange)
For lPtr = 1 To UBound(vaHeadingLine, 2)
vaHeadingLine(1, lPtr) = LCase$(Replace$(vaHeadingLine(1, lPtr), " ", ""))
Next lPtr
Set mrCurrentCell = WS.Cells.Find(what:=iptSearch.Value, LookIn:=xlValues, lookat:=xlPart)
Do While Not (mrCurrentCell Is Nothing)
sCurrentFoundAddress = WS.Name & "!" & mrCurrentCell.Address(False, False)
If sCurrentFoundAddress = msFirstAddress Then Exit Do
If msFirstAddress = "" Then msFirstAddress = sCurrentFoundAddress
If mrCurrentCell.Row > 1 Then
lFoundCount = lFoundCount + 1
ReDim Preserve mvaSearchResults(1 To UBound(mvaSearchResults, 1), 1 To lFoundCount + 1)
vaDataLine = Intersect(WS.Rows(mrCurrentCell.Row), WS.UsedRange)
For lResultsColPtr = 1 To UBound(mvaSearchResults, 1)
sCurHeading = mvaSearchHeadings(lResultsColPtr, 1)
Select Case sCurHeading
Case "#"
mvaSearchResults(lResultsColPtr, lFoundCount + 1) = lFoundCount + 1
Case "Worksheet"
mvaSearchResults(lResultsColPtr, lFoundCount + 1) = WS.Name
Case Else
lColumnPointer = GetHeadingColumn(Heading:=sCurHeading, HeadingArray:=vaHeadingLine)
If lColumnPointer > 0 Then
mvaSearchResults(lResultsColPtr, lFoundCount + 1) = vaDataLine(1, lColumnPointer)
End If
End Select
Next lResultsColPtr
End If
Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
Loop
Next lPointer
If lFoundCount < 0 Then
lblresults.Caption = "No entries found"
Else
Set rResultsRange = mwsSearchResults.Range("A2").Resize(UBound(mvaSearchResults, 2), _
UBound(mvaSearchResults, 1))
rResultsRange.Value = WorksheetFunction.Transpose(mvaSearchResults)
lbs.RowSource = mwsSearchResults.Name & "!" & rResultsRange.Address
lblresults.Caption = lFoundCount + 1 & " entries found"
End If
End If
lbs.Visible = lFoundCount > -1
End Sub
Private Function GetHeadingColumn(ByVal Heading As String, ByVal HeadingArray As Variant) As Long
Dim lPtr As Long
Heading = LCase$(Replace(Heading, " ", ""))
GetHeadingColumn = 0
For lPtr = 1 To UBound(HeadingArray, 2)
If Heading = LCase$(HeadingArray(1, lPtr)) Then
GetHeadingColumn = lPtr
Exit For
End If
Next lPtr
End Function
Private Sub cbContactType_Change()
cmdbNew.Enabled = CBool(cbContactType.ListIndex <> -1)
mstrNo.Value = True
If cbContactType.Enabled Then Set WS = Worksheets(cbContactType.Text)
If cbContactType.Value = "Housing Associations" Or _
cbContactType.Value = "Landlords" Then
mstrAccounts.Visible = True
MLA.Visible = True
Else
mstrAccounts.Visible = False
MLA.Visible = False
End If
lastRow = WS.Range("B" & Rows.Count).End(xlUp).Row
CurrentRow = lastRow + 1
'loop thru and clear textboxes
For i = 1 To 6
Contacts.Controls("txt" & i).Value = ""
Contacts.Controls("txt" & i).BackColor = vbWhite
Contacts.Controls("txt" & i).ForeColor = vbBlack
Contacts.Controls("txt" & i).Visible = True
Next i
Contacts.dtaRow.Caption = lastRow - 1 & " Record"
lblOrganisationName.Visible = True
lblContactName.Visible = True
lblTelephoneNumber.Visible = True
lblEmailAddress.Visible = True
lblPostalAddress.Visible = True
lblPassword.Visible = True
cmdbReset.Enabled = True
cmdbChange.Enabled = True
cmdbDelete.Enabled = True
lb.Visible = True
WS.Activate
lb.RowSource = "B2:H" & lastRow
End Sub
Private Sub cmdbChange_SpinUp()
If CurrentRow < lastRow Then
CurrentRow = CurrentRow + 1
UpdatecmdbChange
Else
CurrentRow = 2
UpdatecmdbChange
End If
lb.ListIndex = CurrentRow - 2
End Sub
Private Sub cmdbChange_SpinDown()
If CurrentRow > 2 Then
CurrentRow = CurrentRow - 1
UpdatecmdbChange
Else
CurrentRow = lastRow
UpdatecmdbChange
End If
lb.ListIndex = CurrentRow - 2
End Sub
Private Sub cmdbReset_Click()
Application.ScreenUpdating = False
Unload Me
Contacts.Show
Application.ScreenUpdating = True
End Sub
Private Sub txt1_AfterUpdate()
If Len(txt1) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub txt2_AfterUpdate()
If Len(txt2) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub txt3_AfterUpdate()
If Len(txt3) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub txt4_AfterUpdate()
If Len(txt4) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub txt5_AfterUpdate()
If Len(txt5) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub txt6_AfterUpdate()
If Len(txt6) > 3 Then cmdbUpdate.Enabled = True
End Sub
Private Sub cmdbUpdate_Click()
If txt1.Value = "" And txt2.Value = "" And txt3.Value = "" _
And txt4.Value = "" And txt5.Value = "" And txt6.Value = "" Then
MsgBox "Please update data in at least one text box.", 48, "Error"
Exit Sub
End If
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
If txt7.Visible = True Then
cNum = 7
Else
cNum = 6
End If
For x = 1 To cNum
'AlignLeft = CBool(x = 1 Or x = 7)
With WS.Cells(CurrentRow, x + 1)
.Value = Me.Controls("txt" & x).Value
End With
Next
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
MsgBox "Contact modified in " & WS.Name, 64, "Success"
End Sub
Private Sub cmdbNew_Click()
If txt1.Value = "" And txt2.Value = "" And txt3.Value = "" _
And txt4.Value = "" And txt5.Value = "" And txt6.Value = "" Then
MsgBox "Please enter data into at least one field.", 48, "Error"
Exit Sub
End If
NextRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
If Len(WS.Cells(1, 2).Value) > 0 Then NextRow = NextRow + 1
If txt7.Visible = True Then
cNum = 7
Else
cNum = 6
End If
For x = 1 To cNum
AlignLeft = CBool(x = 1 Or x = 7)
With WS.Cells(NextRow, x + 1)
.Value = Me.Controls("txt" & x).Value
.EntireColumn.AutoFit
.HorizontalAlignment = IIf(x = 1 Or x = 7, xlLeft, xlCenter)
.VerticalAlignment = xlCenter
With .Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
End With
End With
Controls("txt" & x).Text = ""
Next
MsgBox "Contact added to " & WS.Name, 64, "Success"
Application.ScreenUpdating = False
Unload Me
Contacts.Show
Application.ScreenUpdating = True
End Sub
Private Sub cmdbDelete_Click()
Dim smessage As String
smessage = "Are you sure you want to delete this contact?" & vbCrLf & vbCrLf & "Name: " & txt2.Text & vbCrLf & "From: " & txt1.Text
If MsgBox(smessage, vbQuestion & vbYesNo, _
"Delete") = vbYes Then
WS.Rows(CurrentRow).Delete
End If
lastRow = lastRow - 1
lb.RowSource = "B2:H" & lastRow
End Sub
Private Sub cmdbClose_Click()
Unload Me
End Sub
Private Sub mstrYes_Click()
txt7.Visible = True
End Sub
Private Sub mstrNo_Click()
txt7.Visible = False
End Sub
Private Sub lb_Click()
CurrentRow = lb.ListIndex + 2
UpdatecmdbChange
End Sub
