UserForm to Search Workbook

B

BrendanDixon

Board Regular
Joined
Mar 7, 2010
Messages
174
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi All,

I have a userform called "Search" I have a textbox called "TextBox1"
and a button called "CommandButton1" I would like to have some programming that what ever I type in the text box and then press the button it will go to the cell with with the same text. while keeping the userform on top. if I click on the button again it will go to the next value of the text in the text box. My workbook has multiple sheets and I want the search to ignore Case differences.

Does anyone know how to do this and could you please help me. I do not know where to start with this.
 
Sort by date Sort by votes
Nice solution, how could this be modified to show all the search results at once in a listbox? Also, how can you modify the form behaviour so that once text has been entered you can press the 'enter' key instead of having to click on the search command button?
 
Upvote 0

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Hi, this is the code in Userform1 which contains the objects TextBox1, Label1 and ListBox1:
Code: 
Option Explicit
Dim mrCurrentCell As Range
Dim msaWorksheets() As String
Dim msFirstAddress As String

Private Sub TextBox1_Change()
Dim lPointer As Long
Dim lStartPointer As Long
Dim lFoundCount As Long

Dim sCurName As String
Dim sCurrentFoundAddress As String

Dim vaResults As Variant

Dim WS As Worksheet

Set mrCurrentCell = Nothing
lStartPointer = 1

With ListBox1
    .ColumnCount = 2
    .ColumnHeads = False
    .Clear
End With

ReDim vaResults(1 To 2, 1 To 1)
Label1.Caption = "No entries found"

For lPointer = lStartPointer To UBound(msaWorksheets)
    msFirstAddress = ""
    Set WS = Sheets(msaWorksheets(lPointer))
    Set mrCurrentCell = WS.Cells.Find(what:=TextBox1.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
        lFoundCount = lFoundCount + 1
        ReDim Preserve vaResults(1 To 2, 1 To lFoundCount)
        vaResults(1, lFoundCount) = sCurrentFoundAddress
        vaResults(2, lFoundCount) = mrCurrentCell.Value
        Label1.Caption = lFoundCount & " entries found"
        Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
    Loop
Next lPointer
ListBox1.List = WorksheetFunction.Transpose(vaResults)

End Sub

Private Sub UserForm_Initialize()
Dim iPtr As Integer

ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr

Set mrCurrentCell = Nothing
CommandButton1.Enabled = False
Label1.Caption = ""
With ListBox1
    .ColumnCount = 2
    .ColumnHeads = True
End With
End Sub
 
Upvote 0
A better version is as follows (still using a userform containing "TextBox1", "ListBox1" and "Label1":
Code: 
Option Explicit
Dim mrCurrentCell As Range
Dim msaWorksheets() As String
Dim msFirstAddress As String

Private Sub TextBox1_Change()
Dim lPointer As Long
Dim lStartPointer As Long
Dim lFoundCount As Long

Dim sCurName As String
Dim sCurrentFoundAddress As String

Dim vaResults As Variant

Dim WS As Worksheet

Set mrCurrentCell = Nothing
lStartPointer = 1

With ListBox1
    .Clear
    .ColumnCount = 2
    .ColumnHeads = False
End With

Label1.Caption = ""
lFoundCount = -1

If TextBox1.Text <> "" Then
    ReDim vaResults(0 To 1, 0 To 0)
    
    For lPointer = lStartPointer To UBound(msaWorksheets)
        msFirstAddress = ""
        Set WS = Sheets(msaWorksheets(lPointer))
        Set mrCurrentCell = WS.Cells.Find(what:=TextBox1.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
            lFoundCount = lFoundCount + 1
            ReDim Preserve vaResults(0 To 1, 0 To lFoundCount)
            vaResults(0, lFoundCount) = sCurrentFoundAddress
            vaResults(1, lFoundCount) = mrCurrentCell.Value
            Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
        Loop
    Next lPointer
    If lFoundCount > -1 Then
        If lFoundCount = 0 Then
            With ListBox1
                .Clear
                .ColumnCount = 2
                .AddItem
                .Column(0, 0) = vaResults(0, 0)
                .Column(1, 0) = vaResults(1, 0)
            End With
    '        ListBox1.List = vaResults
            Label1.Caption = "1 entry found"
        Else
            ListBox1.List = WorksheetFunction.Transpose(vaResults)
            Label1.Caption = lFoundCount + 1 & " entries found"
        End If
    Else
        Label1.Caption = "No entries found"
    End If
End If
End Sub

Private Sub UserForm_Initialize()
Dim iPtr As Integer

ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr

Set mrCurrentCell = Nothing
CommandButton1.Enabled = False
Label1.Caption = ""
With ListBox1
    .ColumnCount = 2
End With
End Sub
 
Upvote 0
Hello Alan,

Thank you for your reply.

I have tried using the code within my userform code and it is evident that there is a problem.

Code: 
Option Explicit
Dim iPtr As Integer
Dim mrCurrentCell As Range
Dim msaWorksheets() As String, msFirstAddress As String
Dim objCtrl As Control
Dim cNum As Integer, x As Integer, i As Integer
Dim nextrow As Long
Dim AlignLeft As Boolean

Private Sub UserForm_Initialize()
CheckSize
ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr
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.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 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 lFoundCount As Long

Dim sCurName As String
Dim sCurrentFoundAddress As String

Dim vaResults As Variant

Dim WS As Worksheet

Set mrCurrentCell = Nothing
lStartPointer = 1

With lbs
    .Clear
    .ColumnCount = 7
    .ColumnHeads = False
End With

lblresults.Caption = ""
lFoundCount = -1

If iptSearch.Text <> "" Then
    ReDim vaResults(0 To 1, 0 To 0)
    
    For lPointer = lStartPointer To UBound(msaWorksheets)
        msFirstAddress = ""
        Set WS = Sheets(msaWorksheets(lPointer))
        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
            lFoundCount = lFoundCount + 1
            ReDim Preserve vaResults(0 To 1, 0 To lFoundCount)
            vaResults(0, lFoundCount) = sCurrentFoundAddress
            vaResults(1, lFoundCount) = mrCurrentCell.Value
            Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
        Loop
    Next lPointer
    If lFoundCount > -1 Then
        If lFoundCount = 0 Then
            With lbs
                .Clear
                .ColumnCount = 2
                .AddItem
                .Column(0, 0) = vaResults(0, 0)
                .Column(1, 0) = vaResults(1, 0)
            End With
    '        lbs.List = vaResults
            lblresults.Caption = "1 entry found"
        Else
            lbs.List = WorksheetFunction.Transpose(vaResults)
            lblresults.Caption = lFoundCount + 1 & " entries found"
        End If
    Else
        lblresults.Caption = "No entries found"
    End If
End If
End Sub

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

The search box is called 'iptSearch', the search button is called 'btnSearch', I have inserted a label called 'lblresults' and the listbox is called 'lbs'.

Error:

'Compile error: Expected End With' on 'Private Sub UserForm_Initialize()'

An example can be found here: https://www.dropbox.com/s/k4uvgpbd6wbxooe/AltBKContacts.xlsm?dl=0
 
Last edited:
Upvote 0
Hi,
Yes, the compiler is perfectly correct, the statement "With lbs" doesn't have a matching "End With" which presumably should be just before the "End Sub" of the userform_Initialise sub.
It seems to work if you remove the statement "lbs.visible=false"
 
Upvote 0
.... or re-instate the statement "lbs.visible=False" in the Userform_Initialise and add the following statement to iptSearch_Change at a suitable place (e.g. just before the End Sub):
Code: 
lbs.Visible = iptSearch.Text <> ""
 
Last edited:
Upvote 0
Thanks for your reply.

I looked through the Intialize sub and lbs.visible=False is already present.

I added the code suggested and it's still coming up with the same error:

Code: 
Option Explicit
Dim iPtr As Integer
Dim mrCurrentCell As Range
Dim msaWorksheets() As String, msFirstAddress As String
Dim objCtrl As Control
Dim cNum As Integer, x As Integer, i As Integer
Dim nextrow As Long
Dim AlignLeft As Boolean

Private Sub UserForm_Initialize()
CheckSize
ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr
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.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 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 lFoundCount As Long

Dim sCurName As String
Dim sCurrentFoundAddress As String

Dim vaResults As Variant

Dim WS As Worksheet

Set mrCurrentCell = Nothing
lStartPointer = 1

With lbs
    .Clear
    .ColumnCount = 7
    .ColumnHeads = False
End With

lblresults.Caption = ""
lFoundCount = -1

If iptSearch.Text <> "" Then
    ReDim vaResults(0 To 1, 0 To 0)
    
    For lPointer = lStartPointer To UBound(msaWorksheets)
        msFirstAddress = ""
        Set WS = Sheets(msaWorksheets(lPointer))
        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
            lFoundCount = lFoundCount + 1
            ReDim Preserve vaResults(0 To 1, 0 To lFoundCount)
            vaResults(0, lFoundCount) = sCurrentFoundAddress
            vaResults(1, lFoundCount) = mrCurrentCell.Value
            Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
        Loop
    Next lPointer
    If lFoundCount > -1 Then
        If lFoundCount = 0 Then
            With lbs
                .Clear
                .ColumnCount = 2
                .AddItem
                .Column(0, 0) = vaResults(0, 0)
                .Column(1, 0) = vaResults(1, 0)
            End With
    '        lbs.List = vaResults
            lblresults.Caption = "1 entry found"
        Else
            lbs.List = WorksheetFunction.Transpose(vaResults)
            lblresults.Caption = lFoundCount + 1 & " entries found"
        End If
    Else
        lblresults.Caption = "No entries found"
    End If
End If
lbs.Visible = iptSearch.Text <> ""
End Sub

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
 
Upvote 0
You need the statement "End With" just before the "End Sub"
Add the statement lbs.Visible = iptSearch.Text <> "" '' to the iptSerarch_Change sub and you're in business :)
 
Upvote 0
Better still, is this code which hides the listbox if no entries found:
Code: 
Option Explicit
Dim iPtr As Integer
Dim mrCurrentCell As Range
Dim msaWorksheets() As String, msFirstAddress As String
Dim objCtrl As Control
Dim cNum As Integer, x As Integer, i As Integer
Dim nextrow As Long
Dim AlignLeft As Boolean

Private Sub UserForm_Initialize()
CheckSize
ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr
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.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
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 lFoundCount As Long

Dim sCurName As String
Dim sCurrentFoundAddress As String

Dim vaResults As Variant

Dim WS As Worksheet

Set mrCurrentCell = Nothing
lStartPointer = 1

With lbs
    .Clear
    .ColumnCount = 7
    .ColumnHeads = False
End With

lblresults.Caption = ""
lFoundCount = -1

If iptSearch.Text <> "" Then
    ReDim vaResults(0 To 1, 0 To 0)
    
    For lPointer = lStartPointer To UBound(msaWorksheets)
        msFirstAddress = ""
        Set WS = Sheets(msaWorksheets(lPointer))
        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
            lFoundCount = lFoundCount + 1
            ReDim Preserve vaResults(0 To 1, 0 To lFoundCount)
            vaResults(0, lFoundCount) = sCurrentFoundAddress
            vaResults(1, lFoundCount) = mrCurrentCell.Value
            Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
        Loop
    Next lPointer
    If lFoundCount > -1 Then
        If lFoundCount = 0 Then
            With lbs
                .Clear
                .ColumnCount = 2
                .AddItem
                .Column(0, 0) = vaResults(0, 0)
                .Column(1, 0) = vaResults(1, 0)
            End With
    '        lbs.List = vaResults
            lblresults.Caption = "1 entry found"
        Else
            lbs.List = WorksheetFunction.Transpose(vaResults)
            lblresults.Caption = lFoundCount + 1 & " entries found"
        End If
    Else
        lblresults.Caption = "No entries found"
    End If
End If

lbs.Visible = lFoundCount > -1
End Sub

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
 
Upvote 0
Hey Alan, that's nice functionality! Thank you very much. I like the live results. How do I get the column headers for 'Organisation Name', 'Individual Name', 'Telephone Number' etc (the column headers listed in the worksheets) to all show in the results?

Code: 
Option ExplicitDim iPtr As Integer
Dim mrCurrentCell As Range
Dim msaWorksheets() As String, msFirstAddress As String
Dim objCtrl As Control
Dim cNum As Integer, x As Integer, i As Integer
Dim nextrow As Long
Dim AlignLeft As Boolean


Private Sub UserForm_Initialize()
CheckSize
ReDim msaWorksheets(1 To ThisWorkbook.Sheets.Count)
For iPtr = 1 To UBound(msaWorksheets)
    msaWorksheets(iPtr) = ThisWorkbook.Sheets(iPtr).Name
Next iPtr
Set mrCurrentCell = Nothing
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.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
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 iptSearch_Change()
Dim lPointer As Long
Dim lStartPointer As Long
Dim lFoundCount As Long


Dim sCurName As String
Dim sCurrentFoundAddress As String


Dim vaResults As Variant


Dim WS As Worksheet


Set mrCurrentCell = Nothing
lStartPointer = 1


With lbs
    .Clear
    .ColumnCount = 7
    .ColumnHeads = False
End With


lblresults.Caption = ""
lFoundCount = -1


If iptSearch.Text <> "" Then
    ReDim vaResults(0 To 1, 0 To 0)
    
    For lPointer = lStartPointer To UBound(msaWorksheets)
        msFirstAddress = ""
        Set WS = Sheets(msaWorksheets(lPointer))
        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
            lFoundCount = lFoundCount + 1
            ReDim Preserve vaResults(0 To 1, 0 To lFoundCount)
            vaResults(0, lFoundCount) = sCurrentFoundAddress
            vaResults(1, lFoundCount) = mrCurrentCell.Value
            Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
        Loop
    Next lPointer
    If lFoundCount > -1 Then
        If lFoundCount = 0 Then
            With lbs
                .Clear
                .ColumnCount = 7
                .AddItem
                .Column(0, 0) = vaResults(0, 0)
                .Column(1, 0) = vaResults(1, 0)
            End With
    '        lbs.List = vaResults
            lblresults.Caption = "1 result found"
        Else
            lbs.List = WorksheetFunction.Transpose(vaResults)
            lblresults.Caption = lFoundCount + 1 & " results found"
        End If
    Else
        lblresults.Caption = "No results found"
    End If
End If


lbs.Visible = lFoundCount > -1
End Sub


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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question Question
Searching for text in textboxes in Excel
2
Replies
15
Views
652
DanteAmor
DanteAmor
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
685
Jaafar Tribak
Jaafar Tribak
D
  • Solved
Linking a command button to a text box
Replies
5
Views
71
Logit
Logit
P
  • Solved
New Worksheet Hyperlinks
2
Replies
12
Views
263
Peter_SSs
Peter_SSs
I
  • Solved
Get value from worksheet to userform on another worksheet
2
Replies
13
Views
382
ipbr21054
I

Forum statistics

Threads
1,224,620
Messages
6,179,925
Members
452,949
Latest member
beartooth91

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top