.Findnext command for userform which lists results of several sheets within a workbook.

[TheJay]

Hello there, MrIfOnly has been kindly helping me to develop my userform which enables the user to input new/edit/remove existing data. The original thread is here: https://www.mrexcel.com/forum/excel...try-into-several-different-worksheets-10.html



I am currently working on the search facility. He recommended that I post a new thread specifically on the use of .findnext in relation to this.


With the search facility, it only shows the results from the first worksheet it finds data in, I am not sure how I get it to function properly with the listbox.

[/COLOR][COLOR=#333333]Option Explicit[/COLOR]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
    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, ipi As Integer
Dim sCurName As String
Dim WS As Worksheet
ipi = 1
If Not (mrCurrentCell Is Nothing) Then
    Set WS = ThisWorkbook.Sheets(mrCurrentCell.Parent.Name)
    sCurName = mrCurrentCell.Parent.Name
    Set mrCurrentCell = WS.Cells.FindNext(mrCurrentCell)
    If Not (mrCurrentCell Is Nothing) Then
        If mrCurrentCell.Address = msFirstAddress Then
            Set mrCurrentCell = Nothing
        Else
            mrCurrentCell.Select
            Exit Sub
        End If
    End If
    For ipi = 1 To UBound(msaWorksheets)
        If msaWorksheets(ipi) = sCurName Then
            ipi = ipi + 1
            Exit For
        End If
    Next ipi
End If
For ip = ipi 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
        Sheets(mrCurrentCell.Parent.Name).Select
        mrCurrentCell.Select
        Me.lbs.Visible = True
        CheckSize
        lbs.RowSource = "B2:H" & lastRow
        Exit Sub
    End If
Next ip


If mrCurrentCell Is Nothing Then MsgBox prompt:="Cannot find '" & iptSearch.Value & "'", _
                                        Buttons:=vbOKOnly + vbInformation, _
                                        Title:="Text not found"
End Sub


Private Sub iptSearch_Change()
Set mrCurrentCell = Nothing
btnSearch.Enabled = iptSearch.Value <> ""
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 [COLOR=#333333]End Sub[/COLOR][COLOR=#333333]

The example workbook can be downloaded here: https://www.dropbox.com/s/gooebb7hcm07cqm/BKContacts.xlsm?dl=0

Can someone please help me get this working properly?

 

[MrIfOnly]

Hey Sheepdisease! (you'll have to share the story behind that unfortunate username someday):

I think I got this working for you. Give the following code a try and let me know what you think.

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
    'create named range
        ActiveWorkbook.Names.Add Name:="ResultsData", RefersTo:=.Range("A2:H" & r)
    'populate listbox
        With Me.lbs
            .Visible = True
            .ColumnCount = 8
            .ColumnHeads = True
            .RowSource = "ResultsData"
        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

Regards,

CJ

 

[TheJay]

Thank you for responding, looks like it might work. Couldn't test properly because error kept appearing

Microsoft Forms
Not enough storage is available to complete this operation

Although results did appear, it was not possible to scroll to see the columns on the right.

 

[MrIfOnly]

I have seen that error before with similar code, but I didn't get it in this instance. Temporarily comment out this code:

    Application.DisplayAlerts = False
        .Delete
    Application.DisplayAlerts = True

and let me know if it clears that error.

As for the scroll issue, are you seeing the scrollbar at the bottom of the listbox? If it is off your screen try resizing your userform and listbox manually before running the code, and comment out all instances of this:

CheckSize

I'm not sure what you were trying to achieve with that but it didn't work for me.

Let me know.

CJ

 

[TheJay]

Thank you for the reply. The scrollbar issue was related to the design rather than code so moving the listbox bottom fixed that, thank you.

The error has gone and now I see that the code creates a new worksheet each time displaying the results. I take it the code that I have commented out hid the worksheet and somewhere within the code it is designed to remove the results once the search has been carried out so we don't end up with thousands of worksheets?

I believe that the checksize was just supposed to be for validation but I'm not sure now.

 

[WHW01]

Hi All

I apologise if this is in the incorrect thread or forum, but this is the first time I have use any type of forum.

I have bene browsing to try and find a post on the web to help me create a Macro that will perform something to help me with my job, I know it can be done but my skills are lacking and therefore am looking for some help.

I have a list of values that may appear throughout multiple sheets within a given workbook. the values may appear multiple times. I am aiming to paste the information contained in the cell next the value that I am looking for into a new tab. each time the value I am searching for appears it will have different information in the cell next to it.

I have a basic code I have found but this only finds one value and overwrites it where it finds it.

Sub FindAndExecute()

Dim Sh As Worksheet
Dim Loc As Range

For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="Question?")
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
Loc.Value = "Answered!"
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next

End Sub

Any help or guidance would be massively appreciated.

Thank you

 

[MrIfOnly]

@Sheepdisease: The code I had you comment out actually deleted the new worksheet and has caused problems in the past. I'll work on a fix for it and get back to you. In the meantime, don't run any more searches or you will break your computer with worksheets overload!

@WHW01: Please start a new thread for your issue. Thank you.

CJ

 

[TheJay]

Thank you. If we are using this method to produce the search results, will the results appear in the order that the worksheets appear and which row within each sheet that data is found?

As an aside, can we make sure whenever data is added, updated or remove the relevant worksheet is sorted in alphabetical order, firstly by organisation name and secondly by individual name?

 

[MrIfOnly]

Ok, here's the fix for the memory error:

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
            .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

Unfortunately, this method of populating the listbox doesn't allow for column headers, but should work fine otherwise.

As for sorting, record a macro to sort each worksheet of data. Combine each recorded macro into one public sub in a standard module and call it something like "SortData". Then, in each place in the userform code you would like to perform the sort call SortData.

Regards,

CJ

 

[TheJay]

Thank you for your reply.

Is there no way to get the column headings to appear whilst avoiding the errors? It looks odd having them as an entry on the first row.

With regards to sorting, I was hoping that the action would be performed only on the sheet that has been modified by the userform, which will make it happen quicker. How do we do this as it will be conditional?