Free Microsoft Excel 2013 Quick Reference

Remove string from textbox Results

I am using this code so that when a user checks a checkbox it modifies a textbox but then when he unchecks it, it will reverse the modification:

If Me.cbNew1 Then
        With Me.tbProdDesc1
            .ForeColor = RGB(255, 0, 0)
            .Font.Bold = True
        End With
        Me.tbProdDesc1.Value = "*NEW " & Me.tbProdDesc1.Value
    Else
        With Me.tbProdDesc1
            .ForeColor = RGB(0, 0, 0)
            .Font.Bold = False
        End With
    End If
The whole things works perfectly but how do I get it so that the "*NEW " removes from the textbox without affecting the rest in the textbox?

Hello again,

What I am currently working on, is forming a graph of a specific raw data sheet. There are 2 area's of data that go into this graph. One is temperature (x-axis) and one is Tan Delta (y-axis). Once this graph is formed what I want to do, is find the maximum tan delta value from the raw data sheet. Then find the temperature value that is associated in the column to the left of it. I want to take that tan delta value and put it into a textbox on the graph.

I can't figure out how to insert a textbox with the value from the raw data sheet onto the graph using VBA. Any help with this would be awesome

Thanks a lot!

The example code I have forming this graph is shown below.


	VB:
	
 tgchart() 
    Dim x As Integer 
    x = 0 
    Dim y As Integer 
    y = 0 
    Dim LastColumn As Integer 
    LastColumn = 0 
    Dim p As Integer 
    p = 1 
    Dim tgchart As Chart 
    Dim other As Range 
    Dim frequency As Range 
    Dim title As String 
     ' Set various application properties.
    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
     
    ActiveSheet.Shapes.AddChart.Select 
    ActiveChart.Parent.Name = "TgGraph" 
    ActiveChart.SetSourceData Source:=Range("'Raw Data'!$A$1:$A$1") 
    Set tgchart = ActiveChart 
    With tgchart 
        ActiveChart.ChartType = xlXYScatterSmooth 'Type of graph
         
         ' Remove any series created with the chart
        Do Until .SeriesCollection.Count = 0 
            .SeriesCollection(1).Delete 
        Loop 
         
        ActiveChart.ApplyLayout (1) 
        ActiveChart.ChartTitle.Select 
        ActiveChart.ChartTitle.Text = "Eplexor - Tg" 'Chart Title
        ActiveChart.Axes(xlValue).AxisTitle.Select 
        ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Temperature (°C)" 'X-axis
        ActiveChart.Axes(xlValue).AxisTitle.Select 
        ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Tan Delta" 'Y-axis
        ActiveChart.Legend.Select 
        Selection.Position = xlBottom ' Moves legend to bottom of chart
         
         ' Loops through raw data
        For y = 1 To 1000 
            Cells(1, y).Select 
            If Cells(1, y).Value = "" Then 
                Exit For 
            End If 
            title = Cells(1, y).Value 'Creates Title of graph
             
            Cells(4, y).Select 
            Range(Selection, Selection.End(xlDown)).Select 
            Set frequency = Selection 'Selects x-axis data for chart
            Cells(4, y + 1).Select 
            Range(Selection, Selection.End(xlDown)).Select 
            Set other = Selection 'Selects y-axis data for chart
             
             ' Plugs all data selected in previous section into chart
            Set srs = .SeriesCollection.NewSeries 
            With srs 
                .Name = title 
                .Values = other 
                .XValues = frequency 
            End With 
             
            y = y + 1 '# of cells until next (0C) graph
        Next y 
    End With 
    ActiveSheet.ChartObjects("TgGraph").Activate 
    ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="Tg Chart" 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Sample Data would look something like this, but with more numbers:

Temperature Tan Delta

21.42 1.1234
-321.21 1.3453
-7.77 1.0432
9.543 2.9322

I am trying to use VBA to create an entire userForm from code. For a previous spreadsheet I had already created the userform that I wanted, but now I'm trying to make the spreadsheet more applicable to scenarios outside of my original.

The following code creates the userform, adds the multipage with # of tabs and names created by ranges in the spreadsheet. But I can't figure out how to get the code to add textboxes (checkboxes, comboboxes, etc.) to each page of the multipage.


	VB:
	
 MakeForm() 
     
    Dim TempForm As Object ' VBComponent
    Dim FormName As String 
    Dim NewButton As MSForms.CommandButton, NewMulti As MSForms.MultiPage 
    Dim NewPage As MSForms.Pages 
    Dim NewTbx As MSForms.TextBox, NewCbo As MSForms.ComboBox 
    Dim NewChk As MSForms.CheckBox, NewLbl As MSForms.Label 
    Dim TextLocation As Integer 
     
    Dim loopvar1 As Integer, loopvar2 As Integer, loopvar3 As Integer 
     
    Application.VBE.MainWindow.Visible = False 
    Application.ScreenUpdating = False 
     
     '   Create the UserForm
    Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3) 
     
    With TempForm 
        .Properties("Caption") = TempForm.Name 
        .Properties("Width") = 350 
        .Properties("Height") = 350 
    End With 
    FormName = TempForm.Name 
     
     '   Add a MultiPage
    Set NewMulti = TempForm.designer.Controls.Add("forms.MultiPage.1") 
    With NewMulti 
        .Pages.Remove (1) 'must delete the two pages that are automatically created
        .Pages.Remove (0) 
        .Name = "MultiPage1" 
        .Width = 340 
        .Height = 250 
        .Left = 0 
        .Top = 5 
        .Pages.Add ("Page 1") 
        For loopvar1 = 1 To Range("numTabs").Value 
            .Pages.Add (Range("tab" & loopvar1 & "name").Value) 
        Next 
    End With 
     
     ' loop to add features to the plan design tabs of multipage
    For loopvar1 = 1 To Range("numTabs").Value 
        Set NewPage = TempForm.designer.Controls.forms.MultiPage.Pages(loopvar1) 
        For loopvar2 = 1 To 4 'TextBoxes
            With NewPage 
                 
                 'this is where I want to add the items to go on the multipage
                 
            End With 
        Next 
    Next 
     
    VBA.UserForms.Add(FormName).Show 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Tabs other than "Page 1" will be the same in design.

I'm expecting that the issue is in the Set NewPage command, but then I also can't find the right command to create the items wanted.

Here's what the existing form created in VBE looks like and what I'm trying to replicate through VBA.
userform.JPG

Thanks for any and all help.

This is my first spreadsheet which includes a userform with menus. Up to this point I have been able to find examples in multiple different forums from others asking the same or similar questions. This last part has me stumped. I also have no background in VB or the like. I have more experience with DOS and batch files than VB. The original code was set to search for the value typed into the TitleBox, then display the results into the ListBox in three columns as Title, Worksheet, Worksheet and Cell location. I have removed coding for the Worksheet and Cell location, but would rather have it list the Year, which is in the column next to the title in the worksheets being searched. The ListBox would then show Title, Year, Worksheet as the new results. Thank you for any and all help, it is more than appreciated. Below is the search code thus far. I can also attach an example spreadsheet as well if that would be more helpful for anyone attempting to help.


	VB:
	
 Range) 
     
    Dim rngFind As Range 
    Dim strFirstFind As String 
     
    With Data 
        Set rngFind = .Find(Name, LookIn:=xlValues, lookat:=xlPart) 
        If Not rngFind Is Nothing Then 
            strFirstFind = rngFind.Address 
            Do 
                If rngFind.Row > 1 Then 
                    ListBox.AddItem rngFind.Value 
                    ListBox.List(ListBox.ListCount - 1, 1) = Data.Parent.Name 
                End If 
                Set rngFind = .FindNext(rngFind) 
            Loop While Not rngFind Is Nothing And rngFind.Address  strFirstFind 
        End If 
    End With 
     
End Sub 
 
Private Sub SearchButton_Click() 
     
    Dim ws As Worksheet 
     
    ListBox.Clear 
    For Each ws In ThisWorkbook.Worksheets 
        Locate TitleBox.Text, ws.Range("A:A") 
    Next 
    If ListBox.ListCount = 0 Then 
        ListBox.AddItem "No Match Found" 
        ListBox.List(0, 1) = "" 
        ListBox.List(0, 2) = "" 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I am trying to do a mass info update through a website. I've got most everything figured out except hoe to enter the actual value. The full code is at the end.

The line from the site's HTML: (sorry, I can not post the URL)
With name="00N40000002ESq4" being the important bit.

However this bit of my code isn't working:
I've done other macros like this where I was able to just insert the Name before .Value, but I'm guessing that the
non-standard naming is throwing things off.

Full Code:
Sub UpdateAHAID()

Dim X As Long
Dim URL As String
Dim IE As InternetExplorer
Dim AHAID As Long
Dim hDoc As HTMLDocument
Dim Elem As IHTMLElement

Set IE = New InternetExplorer

X = 15 'Remove after testing.

'For X = FirstRow to LastRow
    URL = "https://FirstHalfOfUrl" & Worksheets("Data").Cells(X, 1).Value &
"SecondHalfOfUrl"
    IE.Navigate (URL)
    IE.Visible = True 'Change to False after testing.
    Do ' Wait till the Browser is loaded
    Loop Until IE.readyState = READYSTATE_COMPLETE
    Set hDoc = IE.document

'name="00N40000002ESq4"  This is the name pulled from the HTML source code.
    hDoc.all.00N40000002ESq4.Value = AHAID
    
    For Each Elem In hDoc.getElementsByTagName("input")
        If Elem.Type = "submit" And Elem.Title = "Save" Then
            Debug.Print Elem.Name
            Elem.Click
            Exit For
        End If
    Next
    'IE.Quit
'Next X

End Sub


In a User Form, the user enters in records to be removed from the list.
He will enter info in the textboxes in the following layout. It will
allow 13 records to be identified in the userform.

Textboxes 1-25 (odd numbers only) are for "PO Numbers" (13 total
records).
Textboxes 2-26 (even numbers only) are for "Taken By".
TextBoxes 27-39 are for "Pieces Moved".
Textbox 41 is the default date to be applied to each record. Together,
this allows for 13 records to be designated for delete. This puts data
in for each of the records. A macro later will actually remove them
from the list.

The For-Next below will look at each of the "PO Number" boxes, and
if there is an entry, will test to make sure it's on the list, and
also for duplicates. Then it will post the "Taken By", "Pieces
Moved", and the default date to that record on the list.

The good news is if all of the textboxes (13 records) are filled, then
this works perfect.

Here's the problem:
If there are any less than 13 PO Numbers entered, then only the 1st
record is done correctly. Only the default date is entered for the
others. The "Pieces Taken", and
"Taken By" data is not.

Can anyone figure out why this will work only if all 13 records are
filled in? I'm just learning about the For-Next loops, so it's
hard for me to see what may be the problem.
Thanks to Bob Phillips for the core of this sub. Maybe Bob, or someone
else can stumble upon this, and figure out what I'm looking for.

Thanks,
J.O.

Declarations
Public rngToSearch As Range
Public rngFound As Range
Public PONum As String
Public CountPOtoValidate As String

Sub DeleteTest()

Dim i As Long

For i = 1 To 13
'This will check to make sure there is 1
'and only 1 of this PO number on list.
Worksheets("Official List").Activate
If Me.Controls("TextBox" & i * 2 - 1).Text <> "" Then
PONum = Me.Controls("TextBox" & i * 2 - 1).Text

' Worksheets("Official List").Activate
CountPOtoValidate = Application.CountIf(Range("J:J"),
PONum)
End If

If CountPOtoValidate < 1 Then
MsgBox "This record does not exist on the list." &
vbNewLine & _
"Please check the PO number and try again"

ElseIf CountPOtoValidate > 1 Then
MsgBox "There are duplicate records." & vbNewLine & _
"Highlight this record on the list, then see the
supervisor."

Else

'This will post the entries from TextBoxes 2, 27 & 41
'for the PO# entered in TextBox1, 3, 5, etc.
Set rngToSearch = Sheets("Official List").Columns("J")
Set rngFound = rngToSearch.Find(What:=PONum, _
LookIn:=xlValues)

rngFound.Select
ActiveWorkbook.Names.Add Name:="DeletePOCell",
RefersTo:=ActiveCell

Application.Goto Reference:="DeletePOCell"
ActiveCell.Offset(0, 4).Select
Application.Selection.Value = _
Me.Controls("TextBox" & 26 + i).Text 'Pieces moved
ActiveCell.Offset(0, 2).Select
Application.Selection.Value = _
UCase(Me.Controls("TextBox" & i * 2).Text) 'Taken By
ActiveCell.Offset(0, 1).Select
Application.Selection.Value = TextBox41.Text 'Default
date
Cancel = False
ActiveWorkbook.Names("DeletePOCell").Delete

End If

Next i

End Sub

Hi all,

I have a worksheet that has a long list of ID numbers arranged in row 2.

I have a userform that lets the user enter comma delinated values in a textbox. The script on the OK button on this user form checks the validity of the entered IDs, and if valid, then removes that ID and associated records from the activesheet and other worksheets.

I've been asked to upgrade the functionality of this form so the user can do batch removals using ranged entries.

i.e. they want to be able to make an entry like "1, 3, 7, 10-25, 33, 45") and have all 21 of those values removed (and validity tested, of course).

Sounded trival to them, but I have no idea how to approach this at all. I've played with a few ideas but nothing has really worked.

My current code is as follows:

(userform textbox value replaced with simple activecell value.

To use:
1. place a series of integer values in column 1
2. place a series of comma delinated integer values in another cell
3. select that cell and fire the procedure)

Private Sub CommandButton1_Click()

    Dim I As Long
    Dim valueString As String
    Dim x As String
            
    valueString = ActiveCell.Value                  ' the thing to parse
    I = InStr(valueString, ",")                     ' find the first comma
    
    If (I = 0) Then                                 ' if no commas (single value)
        x = Trim(valueString)
        If IsNumeric(x) = False Then
            GoTo invalidInteger
            Exit Sub
        End If
        valueCheck (x)
    End If

    Do Until (valueString = "")
  
        If (I = 0) And (valueString <> "") Then     ' check in case our source does not end with a comma
            x = Trim(valueString)
            valueString = ""
        Else
            x = Trim(Left(valueString, I - 1))      ' get the latest value
            valueString = Mid(valueString, I + 1)   ' strip the value already gotten
        End If

        If IsNumeric(x) = False Then
            GoTo invalidInteger
            Exit Sub
        End If

        valueCheck (x)
        I = InStr(valueString, ",")                 ' find the next comma

    Loop
    
Call valuesOK
End

invalidInteger:
    MsgBox "Invalid Entry." & Chr$(13) _
            & x & " is not a valid numerical value." & Chr$(13) & Chr$(13) _
            & "Please enter only interger values."
    
End Sub

'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

Private Sub valueCheck(ByVal x As String)

    Dim I As Integer
    Dim lRow As Integer
        lRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    For I = 1 To lRow
        If ActiveSheet.Cells(I, 1).Value = x Then
            GoTo IsTrue
        End If
    Next I
    
    MsgBox "Invalid entry." & Chr$(13) _
            & x & " is not a valid ID number."
    End
               
IsTrue:

End Sub

'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

Private Sub valuesOK()

    Dim I As Long
    Dim valueString As String
    Dim x As String
            
    valueString = ActiveCell.Value                  ' the thing to parse
    I = InStr(valueString, ",")                     ' find the first comma
    
    If (I = 0) Then                                 ' if no commas (single value)
        x = Trim(valueString)
        removeValue (x)
    End If

    Do Until (valueString = "")
  
        If (I = 0) And (valueString <> "") Then     ' check in case our source does not end with a comma
            x = Trim(valueString)
            valueString = ""
        Else
            x = Trim(Left(valueString, I - 1))      ' get the latest value
            valueString = Mid(valueString, I + 1)   ' strip the value already gotten
        End If

        removeValue (x)
        I = InStr(valueString, ",")                 ' find the next comma

    Loop


End Sub

'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

Private Sub removeValue(ByVal x As String)
    
    Dim I As Integer
    Dim lRow As Integer
        lRow = ActiveSheet.Cells(Rows.Count, 1End(xlUp).Row

    For I = 5 To lRow
        If ActiveSheet.Cells(I, 1).Value = x Then
            ActiveSheet.Cells(I, 1).Value = ""
            ActiveSheet.Cells(I, 2).Value = ""
            ActiveSheet.Cells(I, 3).Value = ""
            GoTo NextValue
        End If
    Next I

NextValue:

End Sub
Any input on how this could be done, or input about tightening the code I have would be greatly appriciated!

--Ouka

Say I have 2 textboxes called textboxA and TextboxB. TextboxA will have a long string and TextboxB will have a small string. If I find TextboxB in TextboxA's String - then I want to remove that piece from TextboxA. Is this possible? here is an example:

TextboxA: Tuna, Tongol 4/3 lb
TextboxB: 4/3 lb

I want to remove what is in TextboxB from TextboxA so I would get this:

TextboxA: Tuna, Tongol
TextboxB: 4/3 lb

the string that needs to be removed from TextboxA will not always be at the end of it and will not always contain numbers. Sometimes it will be all letters sometimes letters and numbers, etc.

I have a texfile that populates a textbox on a userform. I would like to remove all blank lines in the string including those at the end if they exist, before populating the textbox. I'm reading the entire file at once into the string, not line by line.

Is there any way to edit the string called Text to remove the blank lines before populating the textbox? I'm looking for 2 carriage return characters in a row, and if so then remove one of them, but I don't know how to code that. This is in the userform activate section.

If I read the textfile line by line, I don't know how to populate the textbox that way and remove the blank lines.

Private Sub UserForm_Activate()
Dim FileName As String
  Dim FSO As Object
  Dim Text As String
  Dim TextFile As Object
  FileName = "C:Documents and Settingssmithsample.txt"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set TextFile = FSO.OpenTextFile(FileName, 1, False, -2)
  'Read the file into a string
  Text = TextFile.ReadAll
  TextFile.Close
  ' Edit out the blank lines here  
  Me.TextBox1 = Text
End Sub
Please see the example workbook and textfile.

I am having a problem with a TextBox in a UserForm.

Private Sub TextBox130_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim MyPrompt As String
MyPrompt = "Please input a Number!"

If IsNumeric(TextBox130.Value) Then

TextBox130.Value = Round(TextBox130.Value, 0)
JobArea(0).SqFt = TextBox130.Value
Call UpdateSqFtTotal

Else
Cancel = True
TextBox130.Text = ""

MsgBox MyPrompt, vbInformation, "Pro Paver Installer Data Input"

End If

End Sub

The problem I am having is that when a character is entered and after you
click OK on the MsgBox there is no cursor in TextBox130. There is no cursor
on the UserForm. If you type, nothing appears on the UserForm. If you hit
enter after typeing, the MsgBox appears but nothing is displayed in the
TextBox130. If you place the mouse pointer in another textbox and click, the
MsgBox appears. I have tryed placing TextBox.SetFocus before and after the
MsgBox but that does not help.
For TextBox130 this is the only code that is active.

If you remove the MsgBox from the code the code works correctly. But I
would like to display a message if the incorrect data is entered.

I am using Excel 2000. I have been at other forms and people tell me the
code works for them. What else could be wrong with my code?

Thanks for any help.
--
SailFL

For a visual aid I am using a msgbox to view my results. I have "Scenerio 1" and 2.
Snippet of code (CommandButton1):
sFCF = "[" & sLbItem1 & "|" & sLbItem2 & sTolerance & sModifier &
"|" & sPriDat & _
sModifier1 & "|" & sSecDat & sModifier2 & "|" & sTerDat & sModifier3 &
"]"

MsgBox sFCF
Definitions: This character "|" is called a "piping" symbol (its old school, dont ask).

Assume the following (Scenerio 1):
sLbItem1 = "TP"
sLbItem2 = "Ø"
sTolerance = ".010"
sModifier = "m"
sPriDat = "A"
sModifier1 = ""
sSecDat = ""
sModifier2 = ""
sTerDat = ""
sModifier3 = ""

Actual result of sFCF= [TP|Ø.010m|A||]
Required result of sFCF = [TP|Ø.010m|A] (Removed two extra piping symbols)

Assume the following (Scenerio 2):
sLbItem1 = "TP"
sLbItem2 = "Ø"
sTolerance = ".010"
sModifier = "m"
sPriDat = "A"
sModifier1 = ""
sSecDat = "B"
sModifier2 = "m"
sTerDat = ""
sModifier3 = ""

Actual result of sFCF = [TP|Ø.010m|A|Bm|]
Required result of sFCF = [TP|Ø.010m|A|Bm] (Removed one extra piping symbols)

All of the variables above (Scenrios) are from textbox's less sLbItem1 and sLbItem2 which are Listbox's.
How can I format the string based on the above scenerios?

Attached is the actual userform. (Zipped)

Hello folks.

The use of this userform is to find a customer reference number. Im using two combobox's and a textbox.value that are populated from another workbook.

Though the way it is at the moment it opens the workbook and closes the workbook every time a new value is set to one of the combobox's.

I want to open the workbook on the useform initialize and do everthink the useform need from it. And then on the userform terminate close the workbook. Or somehink to this equlivent so this process of finding the customer referance number goes faster.

Im just a little unsure of the dimmension of the variables for each event. For the source workbook.
Option Explicit

Private Sub ComboBox1_Change()

Dim Cl                  As Range
Dim ClAddress           As String
Dim rSource             As Range
Dim SourceWB

If ComboBox1.MatchFound = True Then
ComboBox2.Enabled = True

        Set SourceWB = Workbooks.Open("C:contacts.xlsm", _
        False, True)
            Set rSource = SourceWB.Worksheets(1).Range("B2:B" & Range("A" &
Rows.Count).End(xlUp).Row)
        If Me.ComboBox1.ListIndex < 0 Then Exit Sub 'if no selection in combobox1 quit
    Me.ComboBox2.Clear 'Clear Name List
    Me.ComboBox2.Value = ""

        Set Cl = rSource.Find(Me.ComboBox1.Value, _
        LookIn:=xlValues, lookat:=xlWhole)

        If Not Cl Is Nothing Then
            ClAddress = Cl.Address
            Do
                Me.ComboBox2.AddItem Cl.Offset(0, 1).Value
                Set Cl = rSource.FindNext(Cl)
            Loop While Not Cl Is Nothing And Cl.Address <> ClAddress
        End If

        SourceWB.Close False ' close the source workbook without saving changes
        Set SourceWB = Nothing
    
End If
End Sub

Private Sub ComboBox2_Change()
Dim Cl                  As Range
Dim ClAddress           As String
Dim rSource             As Range
Dim SourceWB

If ComboBox2.MatchFound = True Then

        Set SourceWB = Workbooks.Open("C:contacts.xlsm", _
        False, True)
            Set rSource = SourceWB.Worksheets(1).Range("B2:B" & Range("A" &
Rows.Count).End(xlUp).Row)
        If Me.ComboBox2.ListIndex < 0 Then Exit Sub 'if no selection in combobox1 quit

        Set Cl = rSource.Find(Me.ComboBox1.Value, _
        LookIn:=xlValues, lookat:=xlWhole)

        If Not Cl Is Nothing Then
            ClAddress = Cl.Address
            Do
            If Me.ComboBox2.Value = Cl.Offset(0, 1).Value Then
                Me.TextBox1.Value = Cl.Offset(0, -1).Value
            End If
                Set Cl = rSource.FindNext(Cl)
            Loop While Not Cl Is Nothing And Cl.Address <> ClAddress
        End If

        SourceWB.Close False ' close the source workbook without saving changes
        Set SourceWB = Nothing
    
End If
End Sub

Private Sub UserForm_Initialize()
Dim ListItems As Variant, i As Integer
Dim SourceWB As Workbook

    With Me.ComboBox1
        .Clear ' remove existing entries from the listbox
        ' prevent the user from seeing the source workbook being opened
        Application.ScreenUpdating = False
        ' open the source workbook as ReadOnly
        Set SourceWB = Workbooks.Open("C:contacts.xlsm", _
        False, True)
        ' get the values you want
        ListItems = SourceWB.Worksheets(1).Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
        SourceWB.Close False ' close the source workbook without saving changes
        Set SourceWB = Nothing
        Application.ScreenUpdating = True
        ListItems = Application.WorksheetFunction.Transpose(ListItems)
        ' convert values to a vertical array
        For i = 1 To UBound(ListItems)
            .AddItem ListItems(i) ' populate the listbox
        Next i
        .ListIndex = -1 ' no items selected, set to 0 to select the first item
    End With
    
    Dim vaItems
    Dim j
    Dim vtemp
    Dim a
    Dim e
    Dim w
            'Store Combobox1 items in a variant array
        vaItems = ComboBox1.List
        ' sort the array
           For i = LBound(vaItems, 1) To UBound(vaItems, 1) - 1
            For j = i + 1 To UBound(vaItems, 1)
               If vaItems(i, 0) > vaItems(j, 0) Then
                   vtemp = vaItems(i, 0)
                    vaItems(i, 0) = vaItems(j, 0)
                    vaItems(j, 0) = vtemp
                End If
            Next j
        Next i
        
        a = ComboBox1.List

        'removing duplicates from array
                With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each e In a
            If e <> "" Then
                If Not .exists(e) Then
                    .Item(e) = VBA.Array(e, "(1)")
                Else
                    w = .Item(e)
                    w(1) = "(" & Replace(Replace(w(1), "(", ""), ")",
"") + 1 & ")"
                    .Item(e) = w
                End If
             End If
         Next
         'clear combobox
          ComboBox1.Clear
          'add the new array back to combobox
         ComboBox1.List = _
         Application.Transpose(Application.Transpose(.items))
       End With
End Sub
Thankyou.
If you would like the thread title changes, let me know what to and ill do it straight away.

Hi everyone,

I am trying to create a database & userform with the ability to add, search,
amend and delete entries across multiple sheets within the same workbook. I would also like to increase the functionality of the search function by giving the user the option to choose between critieria to search on. I have attached the workbook as well as the code...

I have so far successfully managed to implement the 'add' function across the
multiple sheets in the workbook. However, I am unsure what to do to the code to make the 'Search', 'Amend' and 'Delete' functions work across the multiple worksheets. The next step I think is for me to describe what I'm hoping to achieve!

In the code below, I would like three boxes to be used with the search function (1 Textbox, 'BusinessNameTxtBox' & 2 combo
boxes, 'StatusDrpDwn' & 'cmdselectblog' respectively). Ideally, I would like the user to have the ability to choose whether to use all three options or not. If they know the name of the business, they could just put that in the textbox and hit search or they could just choose a status from the relevant combo box and the search would return all entries that match the status from all the worksheets and show these results in the listbox. Regardless of what the user chooses in the top three boxes when doing a search, I would like the listbox to display information pertaining to all three choices in the display.

When the user has performed the search and the results have shown up in the listbox, I would like the user to be able to choose one of the entries in the listbox, this would then automatically fill out all the relevant used fields in the userform with the information from the entry. The user can then make changes and hit 'amend' or hit 'delete' to delete the entry.

Any help with this will be greatly appreciated!

John


	VB:
	
 Range 
Dim c          As Range 
Dim rFound     As Range 
Dim r          As Long 
Dim rng        As Range 
Const frmMax   As Long = 1000 
Const frmHt    As Long = 480 
Const frmWidth As Long = 600 
Dim sFileName  As String 'image name
Dim oCtrl      As MSForms.Control 
 
Option Explicit 
 
Private Sub RegionDrpDwn_AfterUpdate() 
    With Me.CityCountyDrpDwn 
        Select Case RegionDrpDwn.ListIndex 
        Case 0: .List = Sheets("Info").Range("C4:C40").Value 
        Case 1: .List = Sheets("Info").Range("D4:D21").Value 
        Case 2: .List = Sheets("Info").Range("E4:E17").Value 
        Case 3: .List = Sheets("Info").Range("F4:F12").Value 
        Case 4: .List = Sheets("Info").Range("G4:G12").Value 
        End Select 
    End With 
End Sub 
 
Private Sub cmdselectblog_AfterUpdate() 
    With Me.featuredpostareacategory 
        Select Case cmdselectblog.ListIndex 
        Case 0: .RowSource = "Info!I4:I14" 
        Case 1: .RowSource = "Info!L4:L8" 
        Case 2: .RowSource = "Info!O4:O14" 
        Case 3: .RowSource = "Info!R4:R5" 
        Case 4: .RowSource = "Info!U4:U5" 
        End Select 
    End With 
    With Me.featuredpostcategory1 
        Select Case cmdselectblog.ListIndex 
        Case 0: .RowSource = "Info!J4:J5" 
        Case 1: .RowSource = "Info!M4:M9" 
        Case 2: .RowSource = "Info!P4:P5" 
        Case 3: .RowSource = "Info!S4:S5" 
        Case 4: .RowSource = "Info!V4:V5" 
        End Select 
    End With 
    With Me.featuredpostcategory2 
        Select Case cmdselectblog.ListIndex 
        Case 0: .RowSource = "Info!K4:K5" 
        Case 1: .RowSource = "Info!N4:N9" 
        Case 2: .RowSource = "Info!Q4:Q5" 
        Case 3: .RowSource = "Info!T4:T5" 
        Case 4: .RowSource = "Info!W4:W5" 
        End Select 
    End With 
End Sub 
 
Private Sub cmbadd_Click() 
     ' set form to workbook
    Dim sht As Worksheet 
    Dim NextRw As Long 
     
    Set sht = Sheets(Me.cmdselectblog.Value) 
    With sht 
        NextRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 
         
         
         ' enter data from form to worksheet
         
        .Cells(NextRw, 1).Value = Me.BusinessNameTxtBox.Value 
        .Cells(NextRw, 2).Value = Me.StatusDrpDwn.Value 
        .Cells(NextRw, 3).Value = Me.cmdselectblog.Value 
        .Cells(NextRw, 4).Value = Me.ContactNameTxtBox.Value 
        .Cells(NextRw, 5).Value = Me.JobTitleTxtBox.Value 
        .Cells(NextRw, 6).Value = Me.RegionDrpDwn.Value 
        .Cells(NextRw, 7).Value = Me.CityCountyDrpDwn.Value 
        .Cells(NextRw, 8).Value = Me.ActualLocationTxtBox.Value 
        .Cells(NextRw, 9).Value = Me.DirectNumberTxtBox.Value 
        .Cells(NextRw, 10).Value = Me.OtherPhoneNumberTxtBox.Value 
        .Cells(NextRw, 11).Value = Me.EMailAddressTxtBox.Value 
        .Cells(NextRw, 12).Value = Me.WebsiteTxtBox.Value 
        .Cells(NextRw, 13).Value = Me.featblogpost.Value 
        .Cells(NextRw, 14).Value = Me.featblogpostcost.Value 
        .Cells(NextRw, 15).Value = Me.featpostnotes.Value 
        .Cells(NextRw, 16).Value = Me.featuredpostareacategory.Value 
        .Cells(NextRw, 17).Value = Me.featuredpostcategory1.Value 
        .Cells(NextRw, 18).Value = Me.featuredpostcategory2.Value 
        .Cells(NextRw, 19).Value = Me.shopwindow.Value 
        .Cells(NextRw, 20).Value = Me.shopwindowcost.Value 
        .Cells(NextRw, 21).Value = Me.salesnotes1.Value 
        .Cells(NextRw, 22).Value = Me.nletter.Value 
        .Cells(NextRw, 23).Value = Me.nlettercost.Value 
        .Cells(NextRw, 24).Value = Me.salesnotes2.Value 
    End With 
     
     'clear the data in form
    With Me 
        .BusinessNameTxtBox.Value = "" 
        .StatusDrpDwn.Value = "" 
        .cmdselectblog.Value = "" 
        .ContactNameTxtBox.Value = "" 
        .JobTitleTxtBox.Value = "" 
        .RegionDrpDwn.Value = "" 
        .CityCountyDrpDwn.Value = "" 
        .ActualLocationTxtBox.Value = "" 
        .DirectNumberTxtBox.Value = "" 
        .OtherPhoneNumberTxtBox.Value = "" 
        .EMailAddressTxtBox.Value = "" 
        .WebsiteTxtBox.Value = "" 
        .featblogpost.Value = "" 
        .featblogpostcost.Value = "" 
        .featpostnotes.Value = "" 
        .featuredpostareacategory.Value = "" 
        .featuredpostcategory1.Value = "" 
        .featuredpostcategory2.Value = "" 
        .shopwindow.Value = "" 
        .shopwindowcost.Value = "" 
        .salesnotes1.Value = "" 
        .nletter.Value = "" 
        .nlettercost.Value = "" 
        .salesnotes2.Value = "" 
    End With 
End Sub 
 
 
Private Sub cmbDelete_Click() 
    Dim msgResponse As String 'confirm delete
    Application.ScreenUpdating = False 
     'get user confirmation
    msgResponse = MsgBox("This will delete the selected record. Continue?", _ 
    vbCritical + vbYesNo, "Delete Entry") 
    Select Case msgResponse 'action dependent on response
    Case vbYes 
         'c has been selected by Find button
        Set c = ActiveCell 
        c.EntireRow.Delete 'remove entry by deleting row
         'restore form settings
        With Me 
            .cmbAmend.Enabled = False 'prevent accidental use
            .cmbDelete.Enabled = False 'prevent accidental use
            .cmbAdd.Enabled = True 'restore use
             'clear form
            ClearControls 
        End With 
         
    Case vbNo 
        Exit Sub 'cancelled
    End Select 
    Application.ScreenUpdating = True 
End Sub 
 
Private Sub cmbFind_Click() 
    Dim strFind As String 'what to find
    Dim FirstAddress As String 
    Dim rSearch As Range 'range to search
    Set rSearch = Sheet1.Range("a6", Range("a65536").End(xlUp)) 
    Dim f      As Integer 
     
    strFind = Me.BusinessNameTxtBox.Value 'what to look for
     
    With rSearch 
        Set c = .Find(strFind, LookIn:=xlValues) 
        If Not c Is Nothing Then 'found it
            c.Select 
            With Me 'load entry to form
                .BusinessNameTxtBox.Value = c.Offset(0, 1).Value 
                .StatusDrpDwn.Value = c.Offset(0, 2).Value 
                .cmdselectblog.Value = c.Offset(0, 3).Value 
                .cmbAmend.Enabled = True 'allow amendment or
                .cmbDelete.Enabled = True 'allow record deletion
                .cmbAdd.Enabled = False 'don't want to duplicate record
                f = 0 
            End With 
            FirstAddress = c.Address 
            Do 
                f = f + 1 'count number of matching records
                Set c = .FindNext(c) 
            Loop While Not c Is Nothing And c.Address  FirstAddress 
            If f > 1 Then 
                Select Case MsgBox("There are " & f & " instances of " & strFind, vbOKCancel Or vbExclamation Or
vbDefaultButton1, "Multiple entries") 
                     
                Case vbOK 
                    FindAll 
                Case vbCancel 
                     'do nothing
                End Select 
                Me.Height = frmMax 
                 
            End If 
        Else: MsgBox strFind & " not listed" 'search failed
        End If 
    End With 
    If Sheet1.AutoFilterMode Then Sheet1.Range("A8").AutoFilter 
     
End Sub 
 
Private Sub cmbAmend_Click() 
    Application.ScreenUpdating = False 
    If rng Is Nothing Then Goto skip 
    For Each c In rng 
        If r = 0 Then c.Select 
        r = r - 1 
    Next c 
skip: 
    Set c = ActiveCell 
    c.Value = Me.BusinessNameTxtBox.Value ' write amendments to database
    c.Offset(0, 1).Value = Me.StatusDrpDwn.Value 
    c.Offset(0, 2).Value = Me.cmdselectblog.Value 
    c.Offset(0, 3).Value = Me.ContactNameTxtBox.Value 
     'restore Form
    With Me 
        .cmbAmend.Enabled = False 
        .cmbDelete.Enabled = False 
        .cmbAdd.Enabled = True 
        ClearControls 
        .Height = frmHt 
    End With 
    If Sheet1.AutoFilterMode Then Sheet1.Range("A8").AutoFilter 
    Application.ScreenUpdating = True 
    On Error Goto 0 
End Sub 
Sub FindAll() 
    Dim strFind As String 'what to find
    Dim rFilter As Range 'range to search
    Set rFilter = Sheet1.Range("a8", Range("d65536").End(xlUp)) 
    Set rng = Sheet1.Range("a7", Range("a65536").End(xlUp)) 
    strFind = Me.BusinessNameTxtBox.Value 
    With Sheet1 
        If Not .AutoFilterMode Then .Range("A8").AutoFilter 
        rFilter.AutoFilter Field:=1, Criteria1:=strFind 
        Set rng = rng.Cells.SpecialCells(xlCellTypeVisible) 
        Me.ListBox1.Clear 
        For Each c In rng 
            With Me.ListBox1 
                .AddItem c.Value 
                .List(.ListCount - 1, 1) = c.Offset(0, 1).Value 
                .List(.ListCount - 1, 2) = c.Offset(0, 2).Value 
                .List(.ListCount - 1, 3) = c.Offset(0, 3).Value 
                .List(.ListCount - 1, 4) = c.Offset(0, 4).Value 
            End With 
        Next c 
    End With 
End Sub 
 
Private Sub ListBox1_Click() 
     
    If Me.ListBox1.ListIndex = -1 Then 'not selected
        MsgBox " No selection made" 
    ElseIf Me.ListBox1.ListIndex >= 1 Then 'User has selected
        r = Me.ListBox1.ListIndex 
         
        With Me 
            .BusinessNameTxtBox.Value = ListBox1.List(r, 0) 
            .StatusDrpDwn.Value = ListBox1.List(r, 1) 
            .cmdselectblog.Value = ListBox1.List(r, 2) 
            .cmbAmend.Enabled = True 'allow amendment or
            .cmbDelete.Enabled = True 'allow record deletion
            .cmbAdd.Enabled = False 'don't want duplicate
            If ListBox1.List(r, 4) = "Yes" Then 
                .optYes = True 
            ElseIf ListBox1.List(r, 4) = "No" Then 
                .optNo = True 
            End If 
        End With 
    End If 
End Sub 
 
 
Private Sub UserForm_Initialize() 
    Set MyData = Sheet1.Range("a5").CurrentRegion 'database
    With Me 
        .Caption = "TWS Blog Leads Management" 'userform caption
        .Height = frmHt 
        .Width = frmWidth 
    End With 
End Sub 
 
Sub ClearControls() 
    With Me 
        For Each oCtrl In .Controls 
            Select Case TypeName(oCtrl) 
            Case "TextBox": oCtrl.Value = Empty 
            Case "OptionButton": oCtrl.Value = False 
            End Select 
        Next oCtrl 
    End With 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello,

I apologize if this is the wrong place to post this request. I have very limited experience when it comes to VBA - aside from the sink-or-swim constant coding I’ve done for the past week or two. At work, I was given the task to update a training chart, which is to be used for ISO 13485:2003 and 21CFR820 training documents regarding the manufacture of medical devices.

Ozgrid and other online resources have helped substantially in troubleshooting the multiple challenges that I have ran into.

Although it is not complete, it is 90% there. I do not have any sheets protected or hidden at this time, as I will need to do in the end.

The ideal functionality of the macros for the training chart are to:
· Add Employee - Adds the new employee to the correct department and to the training chart, in alphabetical order.

· Switch Employee Department - Moves an employee from their current department list to a new one.

· Train Employee - Trains an employee to a specified module revision.

· Train Multiple - Trains up to 10 employees at once on a module revision.

· Hide / Unhide Employee - Adds or removes an employee from the department lists – essentially, if an employee retires, quits, or is fired. This does not affect their training record; for document maintenance requirements.

· Train Manager - Same as “Train Employees”; however, only managers appear in the list.

· Add Module - Creates a new training module for their ISO / QSR requirements, with an initial revision, and training requirement selections for the 14 departments.

· Update Module Requirements - Updates the Required / Aware status for the training module for the 14 departments.

· Update Module Revision - Updates the listed revision and revision date of a module.

· Change Approver Password - Allows an approver to update their old password with a new one.

--------

Known limitations to the code, which are acceptable, are that:

Departments must be added manually – also requires creation of a new “defined name” for the range in excel.
Managers must be appointed manually
Renaming a module must be done manually
Appointing / hiding a manager must be done manually
Module and Training approvers must be added manually
Modules cannot be deleted – only manually; however, records would need to be maintained, requiring the module information to be stored elsewhere.
Training approvers are not prevented from approving their own training.

There are still a few challenges which I am overcoming; for instance, If a department is empty, the row-source reference is blank, which causes a code error. Also, sometimes a calendar field will be filled out from a previous macro run.

There appear to be a few places where a "loop" feature could speed up the code; however, I've run into difficulties attempting to implement - such as with the department checkboxes.

The code works (so long as your excel/vba version recognizes "Date" - My netbook can't run the code / recognize that value). however, it operates as intended at work.

Since this is to be used for maintenance of medical device training records, I am required to validate performance. Any input to either improve the code, or to perform validation testing on it would be much appreciated.

If any of the code benefits you, feel free to use it. All that I ask is for feedback or recommendations on improving it.

Thanks!
-Daniel
General-Training_Chart20110406v3.xlsm
Note: Since the file exceeds the forum limit size, I have removed the department summary pages, along with the code from two of the macros.

The code for these two are below:

Change_Approver_Password -

	VB:
	
[FONT="]Option Explicit 
Public passok As String 
 
 
Private Sub Cancelbutton_Click() 
    Dim ctl As Control 
    For Each ctl In Me.Controls 
        If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
            ctl.Value = "" 
        ElseIf TypeName(ctl) = "Checkbox" Then 
            ctl.Value = False 
        End If 
    Next ctl 
    Unload Me 
End Sub 
 
Private Sub OKbutton_Click() 
    Dim RowCount As Long 
    Dim ctl As Control 
     
     
     '----verify that the old password is correct and boxes are filled----'
     
    Dim PassrowA As String 
    Dim PrA As String 
    Dim truepass As String 
     
    PrA = cmbapprover.Value 
     
    If Me.cmbapprover = "" Then 
        MsgBox "Please select the correct approver.", vbOKOnly, "Required Data" 
        Me.cmbapprover.SetFocus 
        Exit Sub 
    End If 
     
    With Application.WorksheetFunction 
        PassrowA = .Match(PrA, Sheet_Approver_Passwords.Range("Pass_Approvers"), 0) 
        truepass = .Index(Sheet_Approver_Passwords.Range("PassRange"), PassrowA, 2) 
    End With 
     
     
    If Me.txtoldpass = "" Then 
        MsgBox "Please Enter Your Old Password.", vbOKOnly, "Required Data" 
        Exit Sub 
    ElseIf Me.txtoldpass  truepass Then 
        MsgBox "Password Invalid.", vbOKOnly, "Required Data" 
        Exit Sub 
    End If 
     
    If Me.txtnewpass = "" Then 
        MsgBox "Please Enter Your New Password.", vbOKOnly, "Required Data" 
        Exit Sub 
    End If 
     
     
     '----load password verification page and import txtnewpass value-----'
     
    passok = 0 
    Load Verify_Pass_Update 
    Verify_Pass_Update.txtnewpass = Me.txtnewpass 
    Verify_Pass_Update.Show 
     
     '(in verify, check that new password matches)'
     'if yes, passok = 1 and return to this sheet---'
     
     
     
     '---verification determines "passOK"---'
     
    If passok  1 Then 
        txtnewpass = vbNullString 
         
         '----Update password using commands below---'
    Else 
        MsgBox "Password Successfully Updated." 
         
         
         
        Dim Passcodeline As String 
        Dim A1r As String 
         
        A1r = cmbapprover.Value 
         
        With Application.WorksheetFunction 
            Passcodeline = .Match(A1r, Sheet_Approver_Passwords.Range("Pass_Approvers"), 0) 
             
            .Index(Sheet_Approver_Passwords.Range("PassRange"), Passcodeline, 2) = txtnewpass 
             
        End With 
        For Each ctl In Me.Controls 
            If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
                ctl.Value = "" 
            ElseIf TypeName(ctl) = "Checkbox" Then 
                ctl.Value = False 
            End If 
        Next ctl 
        Unload Me 
    End If 
End Sub 
 
[/FONT] 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Train_Manager


	VB:
	
[FONT="]Option Explicit 
Public passok As String 
Private Sub Train_Manager_Activate() 
    Dim ctl As Control 
    Me.txtdate.Value = "Click the Box -->" 
    For Each ctl In Me.Controls 
        If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
            ctl.Value = "" 
        ElseIf TypeName(ctl) = "Checkbox" Then 
            ctl.Value = False 
        End If 
    Next ctl 
End Sub 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 
    If CloseMode = vbFormControlMenu Then 
        Dim ctl As Control 
        For Each ctl In Me.Controls 
            If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
                ctl.Value = "" 
            ElseIf TypeName(ctl) = "Checkbox" Then 
                ctl.Value = False 
            End If 
        Next ctl 
        Unload Me 
    End If 
End Sub 
Private Sub Calendar1_button_Click() 
    UF_Calendar1.Show 
End Sub 
Private Sub Cancelbutton_Click() 
    Dim ctl As Control 
    For Each ctl In Me.Controls 
        If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
            ctl.Value = "" 
        ElseIf TypeName(ctl) = "Checkbox" Then 
            ctl.Value = False 
        End If 
    Next ctl 
    Unload Me 
End Sub 
 
Private Sub Trainbutton_Click() 
    Dim RowCount As Long 
    Dim ctl As Control 
     
    Dim Revline As String 
    Dim modlev As String 
    Dim revlevel As String 
    modlev = cmbmod.Value 
     
    With Application.WorksheetFunction 
        Revline = .Match(modlev, Sheet_Master_Chart.Range("Modules"), 0) 
        revlevel = .Index(Sheet_Master_Chart.Range("ModRevs"), Revline, 5) 
    End With 
     
    If Me.cmbapprov.Value = "" Then 
        MsgBox "Please Enter a Trainer", vbExclamation, "Enter A Trainer" 
        Me.cmbapprov.SetFocus 
        Exit Sub 
    End If 
    If Me.cmbmgr.Value = "" Then 
        MsgBox "Please Enter the Manager's Name", vbExclamation, "Enter A Name" 
        Me.cmbmgr.SetFocus 
        Exit Sub 
    End If 
    If Me.cmbmod.Value = "" Then 
        MsgBox "Please Enter a Training Module", vbExclamation, "Enter A Name" 
        Me.cmbmod.SetFocus 
        Exit Sub 
    End If 
    If Me.txtdate.Value = "" Then 
        MsgBox "Please Enter an Approval Date", vbExclamation, "Enter A Name" 
        Me.txtdate.SetFocus 
        Exit Sub 
    ElseIf Not IsDate(Me.txtdate) Then 
        MsgBox "Must enter valid date", vbExclamation, "Enter a revision date!" 
        Me.txtdate.SetFocus 
        Exit Sub 
    ElseIf DateValue(Me.txtdate) > Date Then 
        MsgBox "Date cannot be in future", vbExclamation, "Enter a revision date!" 
        Me.txtdate.SetFocus 
        Exit Sub 
    End If 
     
    passok = 0 
    Load Password_Check 
    Password_Check.passperson = Me.cmbapprov 
    Password_Check.Show 
     
    If passok  1 Then 
        For Each ctl In Me.Controls 
            If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
                ctl.Value = "" 
            ElseIf TypeName(ctl) = "Checkbox" Then 
                ctl.Value = False 
            End If 
        Next ctl 
        Unload Me 
    Else 
        Dim ColA As String 
        Dim RowA As String 
        Dim A1c As String 
        Dim A1r As String 
         
        A1c = cmbmgr.Value 
        A1r = cmbmod.Value 
         
        With Application.WorksheetFunction 
            ColA = .Match(A1c, Sheet_Master_Chart.Range("All_Employees"), 0) 
            RowA = .Match(A1r, Sheet_Master_Chart.Range("Modules"), 0) 
            .Index(Sheet_Master_Chart.Range("Training_Area"), RowA, ColA - 1) = revlevel 
             
        End With 
         
        RowCount = Sheet_Employee_Log.Range("A1").CurrentRegion.Rows.Count 
        With Sheet_Employee_Log.Range("A1") 
            .Offset(RowCount, 0).Value = Me.cmbmgr 
            .Offset(RowCount, 1).Value = "Manager" 
            .Offset(RowCount, 2).Value = Me.txtdate 
            .Offset(RowCount, 3).Value = Me.cmbmod 
            .Offset(RowCount, 4).Value = revlevel 
            .Offset(RowCount, 5).Value = Me.cmbapprov 
        End With 
         
         
    End If 
    MsgBox (cmbmgr & " has been successfully trained on " & cmbmod & " at Revision " & revlevel & " by " & cmbapprov & ".") 
     
    For Each ctl In Me.Controls 
        If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
            ctl.Value = "" 
        ElseIf TypeName(ctl) = "Checkbox" Then 
            ctl.Value = False 
        End If 
    Next ctl 
    Unload Me 
End Sub 
 
[/FONT] 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello All
I have seen some code around that allows scrolling in listboxes using the mousewheel. I have also seen some code here on the forums about scrolling through a combobox embedded in a workbook. I have tried adapting both of these to suit a combobox on a userform but I cannot get either to work.

Here is the code that I used for the embedded combobox; I added it to the base code for the userform
Code:
Private Sub ComboBox1_GotFocus()

    'Store the first TopIndex Value
    intTopIndex = ComboBox1.TopIndex
    Hook_Mouse

End Sub

Private Sub ComboBox1_LostFocus()

    UnHook_Mouse

End Sub
I then added the following code to a standard module as stated in the forum post;
Code:
Option Explicit

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Declare Function GetForegroundWindow Lib "user32" () As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Type POINTAPI
  X As Long
  Y As Long
End Type

Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
    pt As POINTAPI
    mouseData As Long ' Holds ForwardBacward flag
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A

Dim hhkLowLevelMouse, lngInitialColor As Long
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public intTopIndex As Integer

'==========================================================================
'Copy the Data from lParam of the Hook Procedure argument to our Struct
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

   CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
   
   GetHookStruct = udtlParamStuct
   
End Function

'===========================================================================
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    'Avoid XL crashing if RunTime error occurs due to Mouse fast movement
    On Error Resume Next

'     Unhook & get out in case the application is deactivated
    If GetForegroundWindow  FindWindow("XLMAIN", Application.Caption) Then
            ComboBox1.TopLeftCell.Select
            UnHook_Mouse
            Exit Function
    End If

    If (nCode = HC_ACTION) Then
   
        If wParam = WM_MOUSEWHEEL Then
       
                ' Don't process Default WM_MOUSEWHEEL Window message
                LowLevelMouseProc = True
           
                ' Change Sheet&DropDown names as required
                With ComboBox1

           
              ' if rolling forward increase Top index by 1 to cause an Up Scroll
                If GetHookStruct(lParam).mouseData > 0 Then
               
                    .TopIndex = intTopIndex - 1
               
                    ' Store new TopIndex value
                    intTopIndex = .TopIndex
               
                Else ' if rolling backward decrease Top index by 1 to cause _
                'a Down Scroll
               
                    .TopIndex = intTopIndex + 1
                   
                    ' Store new TopIndex value
                    intTopIndex = .TopIndex
               
                End If
               
           End With

        End If
       
        Exit Function
   
    End If

    LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function

'=======================================================================
Sub Hook_Mouse()

hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)

End Sub

'========================================================================
Sub UnHook_Mouse()

    If hhkLowLevelMouse  0 Then UnhookWindowsHookEx hhkLowLevelMouse

End Sub
In the first section of the code there is a msgbox that never gets shown so I don't think code is recognizing the mouse wheel at all.

The second set of code that I used was set up to work with a listbox and it works perfectly with a listbox control. The problem is I cannot adapt it to suit a combobox and if I use a breakpoint to see what is happening Excel freezes.
The following code is added to the userforms code;
Code:
Private Sub UserForm_Initialize()
  HookWheel Me, Me.Width, Me.Height, 3
End Sub
Private Sub UserForm_Terminate()
  UnHookWheel
End Sub
Then in a standard module I added the following code;
Code:
Option Explicit
Option Private Module

'************************************************************
'APIs
'************************************************************
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As
Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long,
ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As typeRect) As Long
'used to store screen position for GetWindowRect call
Private Type typeRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'screen factor constants
Private dXFactor As Double 'hold screen Conversion coordinates
Private dYFactor As Double
Private lCaptionHeight As Long
'************************************************************
'Constants
'************************************************************
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const SM_MOUSEWHEELPRESENT = 75
Private lLines As Long
'************************************************************
'Variables
'************************************************************
Private hForm As Long
Public lPrevWndProc As Long
Private lX As Long
Private lY As Long
Private bUp As Boolean
Private frmContainer As msForms.UserForm
'*************************************************************
'WindowProc
'*************************************************************
Private Function WindowProc(ByVal lWnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  'converted from code by Kevin Wilson on thevbzone
  'Test if the message is WM_MOUSEWHEEL
  If lMsg = WM_MOUSEWHEEL Then
    lX = lParam And 65535
    lY = lParam  65535
    bUp = (wParam > 0)
    WheelHandler bUp
  End If
  'Sends message to previous procedure if not MOUSEWHEEL
  'This is VERY IMPORTANT!!!
  If lMsg  WM_MOUSEWHEEL Then
    WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
  End If
End Function

Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double, dHeight As Double, ByVal lLinesToScroll As Long)
  If WheelPresent Then
    Set frmContainer = frmName
    hForm = GetFormHandle(frmName)
    GetScreenFactors hForm, dWidth, dHeight
    lLines = lLinesToScroll
    'create the call back procedure
    'addressof doesn't work in earlier versions but not sure which ones
    lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)
  End If
End Sub

Public Sub UnHookWheel()
  'very important that this is called when the form is unloaded to remove the call back
  Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
End Sub

Private Function GetFormHandle(ByVal frmName As msForms.UserForm, Optional bByClass As Boolean = True) As Long
  'returns a handle to the userform
  Dim strClassName As String
  Dim strCaption As String
  strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", "ThunderXFrame") & vbNullChar
  strCaption = vbNullString
  GetFormHandle = FindWindowA(strClassName, strCaption)
End Function

Public Sub GetScreenFactors(lHwnd As Long, dWidth As Double, dHeight As Double)
  'returns screen factors for conversion to Excel units rather than win coords
  Dim uRect As typeRect
  GetWindowRect lHwnd, uRect
  dXFactor = dWidth / (uRect.Right - uRect.Left)
  dYFactor = dHeight / (uRect.Bottom - uRect.Top)
  lCaptionHeight = dHeight - frmContainer.InsideHeight
End Sub

Private Function WheelPresent() As Boolean
  'function by Kevin Wilson from www.thevbzone.com
  'Check for wheel mouse on Win98, WinNT 4.0, & Win2000
  If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
    WheelPresent = True
    ' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
  ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL")  0 Then
    WheelPresent = True
  End If
End Function

Public Sub WheelHandler(bUp As Boolean)
  Dim ctlFocus As msForms.Control
  Dim ctlName As msForms.Control
  Dim lTopIndex As Long
  Dim bMultiPage As Boolean
  Dim lPage As Long
  Dim lMove As Long
  If Not IsOverForm Then Exit Sub
  Set ctlFocus = frmContainer.ActiveControl
  'if we are in a multipage then need to set the control
  'to whatever the subcontrol is on the active page
  If TypeOf ctlFocus Is msForms.MultiPage Then
    'set the multipage flag
    bMultiPage = True
    'store the page number for the MP
    lPage = ctlFocus.Value
    'set the focus control to the control on the current page
    Set ctlFocus = ctlFocus.SelectedItem.ActiveControl
  End If
  'convert screen coords
  lX = lX * dXFactor
  lY = lY * dYFactor
  lY = lY - lCaptionHeight
  'for anything but a commandbutton and textbox lx is relative to the left
  'and top of the control, so adjust
  If Not (TypeOf ctlFocus Is msForms.CommandButton Or TypeOf ctlFocus Is msForms.TextBox) Then
    'lX = lX + ctlFocus.Left
    'lY = lY + ctlFocus.Top
  End If
  'loop controls, looking for list boxes
  For Each ctlName In frmContainer.Controls
    With ctlName
      If TypeOf ctlName Is msForms.ListBox Then
        'if we are in a multipage
        If bMultiPage = True Then
          'if we are not on the correct page then skip this control
          If lPage  .Parent.Index Then GoTo SkipControl
        End If
        'check right of left bound
        If lX > .Left Then
          'check within width
          If lX < .Left + .Width Then
            'check below top bound
            If lY > .Top Then
              'check within height
              If lY < .Top + .Height Then
                'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
                'if the list is empty there is nothing to scroll
                If .ListCount = 0 Then Exit Sub
                'check scroll direction
                lMove = IIf(bUp, -lLines, lLines)
                'get the new top index
                lTopIndex = .TopIndex + lMove
                'check it is within valid limits
                If lTopIndex < 0 Then
                  lTopIndex = 0
                ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
                  lTopIndex = .TopIndex
                End If
                'set the new top index
                .TopIndex = lTopIndex
                'scroll has been handled so stop looping
                Exit Sub
              End If
            End If
          End If
        End If
      End If
      If TypeOf ctlName Is msForms.ComboBox Then
        'if we are in a multipage
        If bMultiPage = True Then
          'if we are not on the correct page then skip this control
          If lPage  .Parent.Index Then GoTo SkipControl
        End If
        'check right of left bound
        If lX > .Left Then
          'check within width
          If lX < .Left + .Width Then
            'check below top bound
            If lY > .Top Then
              'check within height
              If lY < .Top + .Height Then
                'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
                'if the list is empty there is nothing to scroll
                If .ListCount = 0 Then Exit Sub
                'check scroll direction
                lMove = IIf(bUp, -lLines, lLines)
                'get the new top index
                lTopIndex = .TopIndex + lMove
                'check it is within valid limits
                If lTopIndex < 0 Then
                  lTopIndex = 0
                ElseIf lTopIndex > .ListCount - (.Height / 10) + 2 Then
                  lTopIndex = .TopIndex
                End If
                'set the new top index
                .TopIndex = lTopIndex
                'scroll has been handled so stop looping
                Exit Sub
              End If
            End If
          End If
        End If
      End If
    End With
SkipControl:
  Next ctlName
End Sub

Public Function IsOverForm() As Boolean
  'we can't get the form's coordinates directly when referenced as a form
  'rather than ME within the form's code
  'so call GetWindowRect again in case the form has been moved
  Dim uRect As typeRect
  GetWindowRect hForm, uRect
  With uRect
    If lX >= .Left Then
      If lX = .Top Then
          If lY

Currently I am using this code to copy Text Boxes to a group of worksheets.
What I would like to do is Remove any and all objects and formats including
CF from the sheets first and then Copy Any and all Objects as well as
Formats including CF from the master worksheet (MstrWks) to all the other
sheets in the range.
The objects may be TextBoxes or Command Buttons, The formats would be Cell
width, row height, Cell colors, Number and text formats as well as any
conditional formats.

I received this code from here several months ago and after a few changes
that I made it works perfectly except when I change a textbox I first have
to remove all boxes from all the sheets except the mastersheet.

Sub Copy_All_Text_Boxes()

Dim iCtr As Long
Dim MstrWks As Worksheet
Dim wks As Worksheet
Dim TB As TextBox
Dim NewTB As TextBox
Dim strSH As String

Set MstrWks = Worksheets("01") '-- the worksheet with the correct Formats
and objects.

For iCtr = 1 To 33
Set wks = Nothing
On Error Resume Next
Set wks = Worksheets(Format(iCtr, "00"))
On Error GoTo 0

If wks Is Nothing Then
MsgBox "worksheets: " & Format(iCtr, "00") & " doesn't exist!"
Else
If wks.Name = MstrWks.Name Then
'skip it
Else
For Each TB In MstrWks.TextBoxes
TB.Copy
wks.Paste
Set NewTB = wks.TextBoxes(wks.TextBoxes.Count)
With NewTB
.Top = TB.Top
.Left = TB.Left
'these two probably aren't necessary
.Width = TB.Width
.Height = TB.Height
End With
Next TB
End If
End If
Next iCtr
End Sub

I know I am doing this wrong but it gets me close to what I want
because of the way I am dealing with records.

I am inserting my previous post below. Any help please? How should
this be different?

---

This presents everything the way I want, filtering for the State I
want in the form, and I can dump it to a textbox to edit but NOW I see
that storing the edited version will pose problems.

Basically I see that I went about this all wrong because I am lost
when it comes to knowing how to do this with arrays.

This code populates a listbox by first getting the variable it needs
from a clickable map.

Thanks to anyone who can help me understand.

Scott
------

Private Sub UserForm_Initialize()

Dim Contact As String
Dim phone As String
Dim str As String

'pull the State variable from another sub
'to build the listbox contents

UserForm1.Caption = State
ListBox1.ColumnCount = 4
'I want this to be a multicolumn listbox eventually

On Error Resume Next

EntryCount = 1 'to set the starting value

For Each Cell In Sheets("Security").Range("e2:e2000")

'the State is stored in column E

EntryCount = EntryCount + 1 'since the index starts at zero
'and we use the 1st row as a header

Contact = Cell.Offset(0, -4)
phone = Cell.Offset(0, 2)

str = EntryCount & vbTab & State & vbTab & Contact & vbTab & phone
If Cell = State Then ListBox1.AddItem (str) Else

Next Cell
EntryCount = 0
ListBox1.TextColumn = -1

CommandButton1.Caption = "Edit Selection"
CommandButton2.Caption = "Remove Selection"
End Sub

I am embarassed to show how much I don't know about this.

This presents everything the way I want, filtering for the State I
want in the form, and I can dump it to a textbox to edit but NOW I see
that storing the edited version will pose problems.

Basically I see that I went about this all wrong because I am lost
when it comes to knowing how to do this with arrays.

This code populates a listbox by first getting the variable it needs
from a clickable map.

Thanks to anyone who can help me understand.

Scott
------

Private Sub UserForm_Initialize()

Dim Contact As String
Dim phone As String
Dim str As String

'pull the State variable from another sub
'to build the listbox contents

UserForm1.Caption = State
ListBox1.ColumnCount = 4
'I want this to be a multicolumn listbox eventually

On Error Resume Next

EntryCount = 1 'to set the starting value

For Each Cell In Sheets("Security").Range("e2:e2000")

'the State is stored in column E

EntryCount = EntryCount + 1 'since the index starts at zero
'and we use the 1st row as a header

Contact = Cell.Offset(0, -4)
phone = Cell.Offset(0, 2)

str = EntryCount & vbTab & State & vbTab & Contact & vbTab & phone
If Cell = State Then ListBox1.AddItem (str) Else

Next Cell
EntryCount = 0
ListBox1.TextColumn = -1

CommandButton1.Caption = "Edit Selection"
CommandButton2.Caption = "Remove Selection"
End Sub

Hi all,
This is my first VBA Projet and whilst it works (in it's current stat
/ content), I've stumbled across some problems.
So if you are willing to amble through my ramblings and assist, I'll b
greatfully apreciative of any suggestion / solutions you are willing t
offer.

The Named Array's: 'Doctors' / 'Doctors Array' / 'Doctors Table' al
have data in them currently. And when using the 'RemoveButton' wil
successfully remove all records. But when I attempt to add a recor
fails due to the 'Doctors' Named Array being a #REF error due to th
last record being removed (so I'd concluded).

I attempted to add a dummy record and retried to add a record, but i
again fell over as (-and I'm assuming here again-) due to not enoug
records for the script to work.

My questions a a
- Do I need to re-write what I've completed thus far ?
- Need to build a user function to handle this problem?
- Have I overlooked some basic fundamentals in the design of th
script?
- Is my existing code well structured??
- Areas of improvement ??
- Need to see a shrink?aAgain any help is apreciated.
-If anyone would like a copy of the XLS to view, let me know.-

Cheers,
Cameron
-Brisbane, Australia-

------------------------------------------------
Code in Worksheet "*Extra Tables*"...

Code
-------------------
Private Sub AddButton_Click()
'ADD DOCTOR
DisableButtons
frmGetDetails.Show
ShowButtons
End Sub

Private Sub DeleteButton_Click()
'REMOVE DOCTOR !!
DisableButtons
frmDltDetails.Show
ShowButtons
End Sub

Public Sub DisableButtons()
CommandButton1.Enabled = False
CommandButton3.Enabled = False
ThisWorkbook.Worksheets("Extra Tables").Range("A1").Select
End Sub

Public Sub ShowButtons()
CommandButton1.Enabled = True
CommandButton3.Enabled = True
ThisWorkbook.Worksheets("Extra Tables").Range("A1").Select
End Su
-------------------
Code in Userform *frmGetDetails*...

Code
-------------------
Sub ClearText()
'Sub to clear values of all TextBox's
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
End Sub

Private Sub CancelButton_Click()
'Hide this form & unload
Me.Hide
Unload Me
End Sub

Private Sub ContinueButton_Click()

Select Case Len(TextBox1.Text)
Case 0
MsgBox "Information Required - Doctors Name." & vbCrLf & _
"This field cannot remain empty.", vbInformation, "Missing Data!"
ContinueButton.Enabled = False
TextBox1.SetFocus
'Drop out of this Sub
Exit Sub
End Select

Select Case Len(TextBox2.Text)
Case 0
MsgBox "Information Required - Brief Detail." & vbCrLf & _
"This field cannot remain empty.", vbInformation, "Missing Data!"
TextBox2.SetFocus
'Drop out of this Sub
Exit Sub
End Select

Select Case Len(TextBox3.Text)
Case 0
MsgBox "Information Required - Address Line 1 Details." & vbCrLf & _
"This field cannot remain empty.", vbInformation, "Missing Data!"
TextBox3.SetFocus
'Drop out of this Sub
Exit Sub
Case Else
Select Case Len(TextBox4.Text)
Case 0
Resp1 = MsgBox("Information Required - Address Line 2 Details." & vbCrLf & _
"Are you sure this line is to be empty?", vbYesNo, "Missing Data!")
If Resp1 = vbNo Then
TextBox4.SetFocus
'Drop out of this Sub
Exit Sub
End If
Case Else
Select Case Len(TextBox5.Text)
Case 0
Resp1 = MsgBox("Information Required - Address Line 3 Details." & _
vbCrLf & "Are you sure this line is to be empty?", vbYesNo, "Missing Data!")
If Resp1 = vbNo Then
TextBox5.SetFocus
'Drop out of this Sub
Exit Sub
End If
End Select
End Select
End Select

'Prompt User with a Message Dialog Box to confirm details.
Resp2 = MsgBox("Please confirn the following details:" & vbTab & vbCrLf & _
"Doctors Name:" & vbTab & TextBox1.Text & "." & vbTab & vbCrLf & _
"Brief Detail:" & vbTab & TextBox2.Text & "." & vbTab & vbCrLf & _
"Address Details:" & vbCrLf & _
vbTab & vbTab & TextBox3.Text & vbCrLf & _
vbTab & vbTab & TextBox4.Text & vbCrLf & _
vbTab & vbTab & TextBox5.Text & vbCrLf & _
vbTab & vbTab & TextBox6.Text, vbYesNo, "Confirm Details Entered.")

If Resp2 = vbYes Then
' Perform AddData Sub
AddData
End If
' Hide this form & unload
Me.Hide
Unload Me

End Sub

Sub AddData()

Dim strVal As String

' Work out what is the last row number under the `Doctors` Named Array.
LastRow = ThisWorkbook.Worksheets("Extra Tables").Range("Doctors").End(xlDown).Row + 1
' Go to last row and insert an entire row.
ThisWorkbook.Worksheets("Extra Tables").Range("F" & LastRow).Select
Selection.EntireRow.Insert
' Insert New Doctor Details
ThisWorkbook.Worksheets("Extra Tables").Range("F" & LastRow).Select
ActiveCell.Value = TextBox1.Text
ThisWorkbook.Worksheets("Extra Tables").Range("G" & LastRow).Select
ActiveCell.Value = TextBox2.Text
ThisWorkbook.Worksheets("Extra Tables").Range("H" & LastRow).Select
' TextBox3.Text (Address Line 1) has to have some value before getting to this point,
' so include it into strVal now.
strVal = TextBox3.Text
' Add remaining Address Lines are required.
If TextBox4.Text "" Then _
strVal = strVal & vbLf & TextBox4.Text
If TextBox5.Text "" Then _
strVal = strVal & vbLf & TextBox5.Text
If TextBox6.Text "" Then _
strVal = strVal & vbLf & TextBox6.Text
'Post Address Lines to ActiveCell
ActiveCell.Value = strVal

' SORT `DoctorsTable` Array
ThisWorkbook.Worksheets("Extra Tables").Range("F15:H" & LastRow).Sort _
Key1:=Range("F15"), Order1:=xlAscending, Key2:=Range("G15"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
' Rebuild Named Ranges that have been expanded.
ActiveWorkbook.Names.Add Name:="Doctors", _
RefersTo:="='Extra Tables'!$F$15:$F$" & LastRow
ActiveWorkbook.Names.Add Name:="DoctorsArray", _
RefersTo:="='Extra Tables'!$F$15:$G$" & LastRow
ActiveWorkbook.Names.Add Name:="DoctorsTable", _
RefersTo:="='Extra Tables'!$F$15:$H$" & LastRow
End Sub

Private Sub TextBox1_Change()
' Ensure Doctors Name
If Len(TextBox1.Text) >= 0 And IsNumeric(VBA.Left(TextBox1.Text, 1)) = False Then
If Len(TextBox2.Text) > 0 Then
If Len(TextBox3.Text) > 0 Then
ContinueButton.Enabled = True
Else
ContinueButton.Enabled = False
End If
Else
ContinueButton.Enabled = False
End If
Else
MsgBox "Docors Names generally don't start with numbers.", _
vbOKOnly, "Incorrect Details !!"
TextBox1.Text = ""
TextBox1.SetFocus
ContinueButton.Enabled = False
End If
End Sub

Private Sub TextBox2_Change()
If Len(TextBox1.Text) >= 0 And IsNumeric(VBA.Left(TextBox1.Text, 1)) = False Then
If Len(TextBox2.Text) > 0 Then
If Len(TextBox3.Text) > 0 Then
ContinueButton.Enabled = True
Else
ContinueButton.Enabled = False
End If
Else
ContinueButton.Enabled = False
End If
Else
ContinueButton.Enabled = False
End If
End Sub

Private Sub TextBox3_Change()

If Len(TextBox1.Text) >= 0 And IsNumeric(VBA.Left(TextBox1.Text, 1)) = False Then
If Len(TextBox2.Text) > 0 Then
If Len(TextBox3.Text) > 0 Then
ContinueButton.Enabled = True
Else
ContinueButton.Enabled = False
End If
Else
ContinueButton.Enabled = False
End If
Else
ContinueButton.Enabled = False
End If
End Sub

Private Sub Userform_Activate()
ClearText
TextBox1.SetFocus
ContinueButton.Enabled = False
End Sub
--------------------

---
Message posted from http://www.ExcelForum.com/

Hi there,
I try to resume my scenario.

I have a cascading combo box to control with VBA.
I did it in filtering the values with the 1st combo and show in 2nd only the filtered items.
Whenever I choose a category from the 1st combo, my 2nd combo list updates, which is fine.
The problem arises when I already selected a category and I want to change it.

My userform displays data (picture, volume, price, etc) in textboxes (in the same userform) when triggered by the changes made in the 2nd combo via match and vlookup VBA formulas.

After the user change again the 1stcombo I clear the 2nd combo to avoid old data would remain at the top of my 2nd combo list..as a result, the code which is 'listening' for changes made in the 2nd combo list shows me a 1004 error, since there's nothing to match.

I created a simple delay in 2ndCombo_change() sub which is activated when 2ndCombo value is null and it works good.
Here's the code:
If sceltaArredi = vbNullString Then
Application.Wait Now + TimeSerial(0, 0, 0.5)
Else
AIM:
Now I want to show a msgBox when a selected choice in 1stCombo reflects in null value for 2ndCombo AFTER the above IF statement.
Some categories of the 1st combo don't have any sub-element yet and I want to tell the user so.

MY TRY:
I changed the 2stCombo_change() sub like this
NOTE: my 2stCombo is named sceltaArredi
Private Sub sceltaArredi_Change()
Dim Match As String ' I initialize the variable here cause after the last THEN I need to provide an action
If sceltaArredi = vbNullString Then
Application.Wait Now + TimeSerial(0, 0, 0.5)
Else
If sceltaArredi = vbNullString _
Then MsgBox "Non ci sono elementi per la categoria scelta!", vbCritical + vbOKOnly, "Nessun elemento
arredo"
Exit Sub
Else: If Not sceltaArredi = vbNullString Then_
Match = WorksheetFunction.Match(sceltaArredi.Value, Worksheets("DATI").Range("DESCRIZIONI_ITA"), 0)
...
[lots of other vlookup, index and match code]
...
End If
End Sub
MORAL:
I get an error at the Else: If row.
If I remove the If condition after that Else debug asks me for it, when I write Else If and reload the userform my code changes like above and still gives me error.

Any hint?

thanks in advance
P.


No luck finding an answer? You could always try Google.