Userform for Data Entry Into Several Different Worksheets

[TheJay]

I am creating a userform to search and manage a list of contacts.

There is currently no search facility whilst I work on getting the data input/edit capability running as it should.

The first function I am trying to implement is decribed below.

The master linked accounts section is hidden unless the corresponding worksheets are selected where this information is applicable. When one of the worksheets that this information is relevant to is selected in the combobox, it should populate MLA option buttons.

I have two option buttons to the form 'MLA' called 'mstrYes' and 'mstrNo'. 'mstrNo' should be the default and I want to prevent the text box 'txt7' from appearing until mstrYes is selected, and if mstrNo is selected again, the text box should disappear again.

Also in relation to the text box 'txt7', how do I prevent the text within 'txt7' that appears automatically in 'Example1, Example2, Example3' mentioned previously from being cleared during the following procedure?

Dim ws As Worksheet

Private Sub cbContactType_Change()
    Me.cmdbNew.Enabled = CBool(Me.cbContactType.ListIndex <> -1)
    If Me.cbContactType.Enabled Then Set ws = Worksheets(cbContactType.Text)
    Me.txt7.Visible = Not IsError(Application.Match(cbContactType.Text, Array("Housing Associations", "Landlords"), False))
    Me.mstrAccounts.Visible = Me.txt7.Visible
    Me.MLA.Visible = Me.txt7.Visible
End Sub




Private Sub iptSearch_Click()
      Contacts.Hide
      Unload Contacts
End Sub




'Private Sub cmdbChange_SpinUp()
'    If Me.cbContactType.ListRows.Count < 1 Then Exit Sub
'    If CurrentRow > 1 Then
'        CurrentRow = CurrentRow - 1
'        UpdatecmdbChange
'    End If
'End Sub




'Private Sub cmdbChange_SpinDown()
'    If CurrentRow = Me.cbContactType.ListRows.Count Then Exit Sub
'    If CurrentRow < Me.cbContactType.ListRows.Count Then
'        CurrentRow = CurrentRow + 1
'        UpdatecmdbChange
'    End If
'End Sub




'Private Sub UpdatePositionCaption()
'    dtaRow.Caption = CurrentRow & " of " & Me.cbContactType.ListRows.Count
'End Sub




Private Sub UserForm_Initialize()
    Me.cbContactType.List = Array("Council Contacts", "Local Contacts", "Housing Associations", "Landlords", "Letting and Selling Agents", "Developers", "Employers")
    Me.cmdbNew.Enabled = False
    Me.txt7.Visible = False
    Me.mstrAccounts.Visible = False
    Me.MLA.Visible = False
End Sub




Private Sub cmdbNew_Click()
Dim cNum As Integer, X As Integer
    Dim nextrow As Long
    nextrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If Len(ws.Cells(1, 2).Value) > 0 Then nextrow = nextrow + 1
    cNum = 7
    Dim AlignLeft As Boolean
    For X = 1 To cNum
    AlingLeft = CBool(X = 1 Or X = 7)
    With ws.Cells(nextrow, X + 1)
        .Value = Me.Controls("txt" & X).Value
        .EntireColumn.AutoFit
        .HorizontalAlignment = IIf(X = 1, xlLeft, xlCenter)
        .VerticalAlignment = xlCenter
        With .Font
             .Name = "Arial"
             .FontStyle = "Regular"
             .Size = 10
        End With
    End With
    Me.Controls("txt" & X).Text = ""
    Next
    MsgBox "Contact added to " & ws.Name, 64, "Contact Added"
End Sub




Private Sub cmdbClose_Click()
Unload Me
End Sub

 

[MrIfOnly]

Also, you can simplify your code a bit by removing all of the textbox.visible = True lines and making the following change (line in red is new):

    'loop thru, show, clear & format textboxes
    For i = 1 To 6
        Contacts.Controls("txt" & i).Value = ""
        Contacts.Controls("txt" & i).BackColor = vbWhite
        Contacts.Controls("txt" & i).ForeColor = vbBlack
        [COLOR=#ff0000]Contacts.Controls("txt" & i).Visible = True[/COLOR]
    Next i

CJ

 

[TheJay]

That's great, thanks.

I don't know if this helps, it looks like it should, but I don't quite understand how to implement this:

If you are using the FORM ListBox, the font color can't be formatted.

If you don't want to fool with VB, you can create a ListBox using the TOOLS, CUSTOM, TOOLBARS, CONTROL TOOLBOX. I like this because you can change the font color and size, and the ListBox background color, among other things.

Courtesy of OzGrid: Excel Listbox individual item font colour...

 

[TheJay]

I think that refers to controls on the actual worksheet so does not apply. However, this looks like it might work:

Change the color of text in a listbox based upon a certain criteria

Instead of using a listbox I've used listview. Add this control by right clicking on the workpalette and choose 'Microsoft Listview Control 6.0 (SP4)'

Once I have inserted this listview control, which I have called lv, I am not sure how to adapt it though:

[COLOR=#333333]Option Explicit [/COLOR][COLOR=darkgreen]'this one above the userform1.initialize[/COLOR]Private Sub UserForm_Initialize() 
    Dim startrow As Integer [COLOR=darkgreen]'beginning of data[/COLOR]
    Dim endrow As Integer [COLOR=darkgreen]'end of data[/COLOR]
    Dim pos As Integer [COLOR=darkgreen]'actual row[/COLOR]
    Dim lv_item As Integer [COLOR=darkgreen]'no of the listview item[/COLOR]
    Dim counting As Integer [COLOR=darkgreen]'loop for processing all items[/COLOR]
    startrow = 2 
     [COLOR=darkgreen]'endrow = xlLastRow("Sheet1")[/COLOR]
     [COLOR=darkgreen]'xllastrow is a function found at this forum otherwise use a number for testing[/COLOR]
     [COLOR=darkgreen]'Sheet1 is the name of your sheet[/COLOR]
    pos = 2 
    lv_item = 1 
    With ListView1 
         [COLOR=darkgreen]'gives me headers at the top[/COLOR]
        .View = lvwReport 
         [COLOR=darkgreen]'defining the columnheaders[/COLOR]
        With .ColumnHeaders 
            .Clear 
            .Add , , "Column 1", 60 
            .Add , , "Column 2", 60 
            .Add , , "Column 3", 60 
            .Add , , "Column 4", 60 
        End With 
        .HideColumnHeaders = False 
        .Appearance = cc3D 
        .FullRowSelect = True 
        For counting = startrow To endrow 
            If Worksheets("Sheet1").Range("B" & pos).Value > 1 Then 
                .ListItems.Add , , Worksheets("Sheet1").Range("A" & pos) 
                .ListItems(lv_item).ForeColor = RGB(255, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("B" & pos) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("C" & pos) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("D" & pos) 
            Else 
                .ListItems.Add , , Worksheets("Sheet1").Range("A" & pos) 
                .ListItems(lv_item).ForeColor = RGB(0, 0, 0) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("B" & pos) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("C" & pos) 
                .ListItems(lv_item).ListSubItems.Add , , Worksheets("Sheet1").Range("D" & pos) 
                lv_item = lv_item + 1 
                pos = pos + 1 
            End If 
        Next counting 
    End With 
End Sub

 

[MrIfOnly]

I've never used the Listview control and I'm not familiar with how it works so I'm afraid I won't be able to help you in this regard. You may want to revive that thread in that forum in hopes that the person who posted that code would be able to help you adapt it to your application. I suggest that you link to this thread so you aren't accused of double-posting and to give some background to whoever may try to help you there.

Sorry I couldn't help more with this.

CJ

 

[TheJay]

Thank you for your reply. I will consider reviewing that functionality at a later date.

Now I am looking to get the logo functionality to work. I found a webpage which seems to make reference to functionality that addresses this: Load picture from worksheet into Excel Userform using combobox selection.

I am looking for a way for a userform to display an image for a particular row within a worksheet (chosen by a combobox) that resizes and centres the image in an imageholder relative to the dimensions of the original (the images will all be different heights and widths).

Then I need a way to easily assign an existing image to multiple rows without copying the actual image each time (which would increase the file size considerably). The only way I can think of would be to add a code word which corresponds with a particular image.

Lastly, is there a way I can insert images using the userform so if I add a new row of data it makes it easy to allocate an image and code word? I want to keep the images within the workbook rather than having separate files as per the original request from the linked page. It would be useful if the images upon insertion could be compressed to a DPI which still looks good but reduces overall file size.

The image would go in the square top right.

 

[MrIfOnly]

How many pictures are we talking about? How will they be named and what will be the relationship to the data? Lastly, can you format them using a photo editor before we bring them into Excel so we don't have to deal with formatting at runtime?

CJ

 

[TheJay]

I have also started to work on the search functionality and autoresizing of the userform.

Dropbox file updated. Border removed from around the logo container.

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
    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
End Sub

At the moment the ChangeSize code seems to immediately make the userform larger and no matter what options are chosen, the form is larger than in its design state. On the search tab, the form should show the search text box and search button until the search button is pressed or the user presses 'enter' (so basically, when the search code is executed). On the update tab the same behaviour should change the form from showing just the 'Contact Type' label and combobox to the entire form when the user selects an option from the combobox. In both instances the height and width of the form will need to change.

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.

 

[TheJay]

In the real spreadsheet there are about 200 logos for local organisations. The height and width depend on the dimensions of their logo.

I was hoping to insert functionality into the userform allowing a picture copied from the clipboard to be inserted and new/existing logos to be modified within the userform (most likely by clicking on the image container to bring up a form which enables this functionality).

I would like the image to be inserted into cell A of the corresponding data row. I don't know about naming, perhaps this could be adhoc according to the organisation name input on the update uderform?

 

[MrIfOnly]

So, I've successfully used the imagelist control in my past projects by creating a userform with up to 10 images then putting those into the imagelist control and then calling those with something like this:

Image1.Picture = Icons.ImageList1.ListImages.Item(2).Picture

Icons is the name of my 'helper' userform. The userform with the images and imagelist is never seen by the user, I just use it for storage and organization. This way all of the images are stored in the workbook and not loaded at runtime making it very quick.

The problem I have is that I click on the custom property of the imagelist control to load in my images, but in Excel 2016 on my home laptop I can't seem to access this property. So, I'm not sure if I can recommend this method to you, but if you want to play around with it, feel free. If you can get it to work, we can easily tie it to the spinbutton and each row of data. I'd be curious to see how excel is going to handle around 200 images though. Personally, I would forget about trying to have these on the worksheets themselves. Not only will it create file size issues, I think, but you are going to have to try to size each row height to the logos. Alternatively, cell A could be used as an identifier for the logos. Just a suggestion, though.

I've seen numerous threads on this forum in regards to dynamically sizing and locating userforms on a screen although I've never had a need to use any of the techniques discussed. You may want to search for help with this.

With the search facility: I will d/l your latest file and take a look and get back to you.

Regards,

CJ

 

[TheJay]

Okay thanks, look forward to hearing back from you.