Slow UserForm

B

Bonz

Board Regular
Joined
Dec 10, 2007
Messages
149
Good Morning All,

I use the below VBA to update a worksheet database with a Userform. The issue I’m having is speed. After the user clicks “Add” the data is transferred to the correct column in the db but it takes about 30 seconds before the form resets and can be used to enter additional info.

I also have a worksheet change event for the sheet containing the db to convert a Y/N box from True/False to Yes/No as indicated below. This is why I don’t turn off events while the macro runs.

Can anyone suggest any changes to the included code or point me in a different direction that will increase the speed?

Thanks for any help in advance.


FORM VBA

Private Sub cmdAdd_Click()
Dim lRow As Long
Dim lLocation As Long
Dim ws As Worksheet

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With


Set ws = Worksheets("BillData")
lLocation = Me.cboLocation.ListIndex


'find first empty row in database
lRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row


'check for a Location
If Trim(Me.cboLocation.Value) = "" Then
Me.cboLocation.SetFocus
MsgBox "Please enter a location"
Exit Sub
End If

'copy the data to the database
With ws
.Cells(lRow, 1).Value = Me.cboLocation.Value
.Cells(lRow, 2).Value = Me.cboUtilities
.Cells(lRow, 3).Value = Me.cboMeter.Value
.Cells(lRow, 4).Value = Me.DTPicker1.Value
.Cells(lRow, 5).Value = Me.txtCost.Value
.Cells(lRow, 6).Value = Me.TxtUsage.Value
.Cells(lRow, 7).Value = Me.CheckBox1.Value
End With

'clear the data
Me.cboLocation.Value = ""
Me.cboUtilities.Value = ""
Me.cboMeter.Value = ""
Me.TxtUsage.Value = ""
Me.DTPicker1.Value = Date
Me.txtCost.Value = ""
Me.cboLocation.SetFocus

End Sub


CHANGE EVENT VBA

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

If Target.Column <> 7 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If Target = "True" Then
Target = "Yes"
ElseIf Target = "False" Then
Target = "No"
End If
End Sub
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Sort by date Sort by votes
I can't see anything in there that would cause execution to be so slow. Do you have any other event procedures that may be firing (UserForm or Worksheet)?
 
Upvote 0
Hi Andrew,

Thanks for taking the time, no other events. I only added the one.

There are several other macros associated with the form but everything goes quickly except the "ADD"
 
Upvote 0
Andrew,

Below is everything in the module for this form including the "Add" VBA sent earlier.

Please let me know if you have any questions.

I'd offer some coffee and an aspirin if I could.

Thanks for looking!



Option Explicit

Sub ShowMeterDataForm()

frmMeterData.Show vbModeless

End Sub


Private Sub cboLocation_Change()

cboUtilities.Clear
cboMeter.Clear
cboUtilities.Clear
LstMeter.Clear
Call UserForm_Initialize

End Sub


Private Sub cmdAdd_Click()
Dim lRow As Long
Dim lLocation As Long
Dim ws As Worksheet

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Set ws = Worksheets("BillData")
lLocation = Me.cboLocation.ListIndex


'find first empty row in database
lRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row



'check for a Location
If Trim(Me.cboLocation.Value) = "" Then
Me.cboLocation.SetFocus
MsgBox "Stephanie Please enter a location"
Exit Sub
End If

'copy the data to the database
With ws
.Cells(lRow, 1).Value = Me.cboLocation.Value
.Cells(lRow, 2).Value = Me.cboUtilities
.Cells(lRow, 3).Value = Me.cboMeter.Value
.Cells(lRow, 4).Value = Me.DTPicker1.Value
.Cells(lRow, 5).Value = Me.txtCost.Value
.Cells(lRow, 6).Value = Me.TxtUsage.Value
.Cells(lRow, 7).Value = Me.CheckBox1.Value
End With

'clear the data
Me.cboLocation.Value = ""
Me.cboUtilities.Value = ""
Me.cboMeter.Value = ""
Me.TxtUsage.Value = ""
Me.DTPicker1.Value = Date
Me.txtCost.Value = ""
Me.cboLocation.SetFocus

End Sub


Private Sub cmdClose_Click()
Application.ScreenUpdating = True
Unload Me
End Sub

Private Sub UserForm_Initialize()

Application.ScreenUpdating = False

Dim AllCells As Range, cell As Range
Dim NoDupes As New Collection
Dim iRow As Integer
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Dim cSiteName As Range
Dim ws As Worksheet
Set ws = Worksheets("LookupLists")
Set AllCells = Range("Utility")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each cell In AllCells
NoDupes.Add cell.Value, CStr(cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next cell

' Resume normal error handling
On Error GoTo 0

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
frmMeterData.cboUtilities.AddItem Item
Next Item

' Resume normal error handling
On Error GoTo 0

For Each cSiteName In ws.Range("SiteName")
With Me.cboLocation
.AddItem cSiteName.Value
End With
Next cSiteName

Me.DTPicker1.Value = Date
Me.txtCost.Value = ""
Me.cboLocation.SetFocus

End Sub



Private Sub cboUtilities_Change()
Dim iRow As Integer
cboMeter.Clear
iRow = 2
With Worksheets("LookupLists")
Do Until IsEmpty(.Cells(iRow, 18))
If .Cells(iRow, 17).Value = cboLocation.Value And _
.Cells(iRow, 18).Value = cboUtilities.Value Then
cboMeter.AddItem .Cells(iRow, 19).Value
End If
iRow = iRow + 1
Loop
End With
End Sub


Private Sub cboMeter_Change()
Dim iRow As Integer
iRow = 2
With Worksheets("LookupLists")
Do Until IsEmpty(.Cells(iRow, 20))
If .Cells(iRow, 17).Value = cboLocation.Value And _
.Cells(iRow, 18).Value = cboUtilities.Value And _
.Cells(iRow, 19).Value = cboMeter.Value Then
frmMeterData.LstMeter.AddItem .Cells(iRow, 20).Value
Exit Do
End If
iRow = iRow + 1
Loop
End With
End Sub
 
Upvote 0
This part of your code:

Code: 
'clear the data
Me.cboLocation.Value = ""
Me.cboUtilities.Value = ""
Me.cboMeter.Value = ""
Me.TxtUsage.Value = ""
Me.DTPicker1.Value = Date
Me.txtCost.Value = ""
Me.cboLocation.SetFocus

causes the events that are associated with those controls to fire (unnecessarily). This shows you how to suppress events in a UserForm:

http://www.cpearson.com/Excel/SuppressChangeInForms.htm
 
Upvote 0
I just wanted to close the loop on this post.

Prior to asking for help the form required 30 seconds every time it was used to refresh.

After Andrew’s help and using the instructions on Cpearson’s site at the link provided it now takes about 2 seconds.

Thanks Again Andrew!
 
Upvote 0
Hi all, I'm also facing the same issue. While searching it is working fine but while clicking on Update button it is updating very slow. Please help me out to I can speed it.

Code: 
' Developed by Raaj Chauhan, India HIV/AIDS Alliance
Option Compare Text
Dim Drugs(), ARTCode(), SD As Object, bul As String, c As Variant ' Dropdown for Drugs and ARTC
Private r As Range, dic As Object ' For State/District/SubDistrict Command
Private Sub CheckBox1_Click() ' Check Box to select all function
    Dim r As Long
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ListBox1.ListIndex = -1
    If CheckBox1.Value = True Then
        ListBox1.MultiSelect = fmMultiSelectMulti
        For r = 0 To ListBox1.ListCount - 1
            ListBox1.Selected(r) = True
            Next r
        Else
            ListBox1.MultiSelect = fmMultiSelectSingle
            For r = 0 To ListBox1.ListCount - 1
                ListBox1.Selected(r) = False
                Next r
            End If
            With Application
                .Calculation = xlCalculationAutomatic
                .ScreenUpdating = True
                .EnableEvents = True
            End With
        End Sub


Private Sub Cmdbutton1_Click()
    If TextBox102 = 0 Then
        Exit Sub
    End If
    If ListBox1.ListIndex = 0 Then
        MsgBox "First Record", vbCritical, ""
        Exit Sub
    Else
        On Error Resume Next
        TextBox102 = TextBox102 - 1
        With Me.ListBox1
            .ListIndex = .ListIndex - 1
        End With
    End If
End Sub


Private Sub Cmdbutton2_Click()
    If ListBox1.ListIndex = ListBox1.ListCount - 1 Then
        MsgBox "Last Record", vbCritical, ""
        Exit Sub
    Else
        On Error Resume Next
        TextBox102 = TextBox102 + 1
        With Me.ListBox1
            .ListIndex = .ListIndex + 1
        End With
    End If
End Sub


Private Sub Cmdbutton3_Click() 'FIRST RECORD BUTTON
        On Error Resume Next
        Application.ScreenUpdating = False
        ListBox1.ListIndex = 0
        Application.ScreenUpdating = True
End Sub


Private Sub Cmdbutton4_Click() 'LAST RECORD BUTTON
        On Error Resume Next
        Application.ScreenUpdating = False
        ListBox1.ListIndex = ListBox1.ListCount - 1
        Application.ScreenUpdating = True
End Sub
Private Sub ComboBox1_Change()
    If ComboBox1.ListIndex = 3 Then
        SearchSection.Visible = True
        SearchSection.ListIndex = 0
    Else
        SearchSection.Visible = False
    End If
End Sub


Private Sub cmdNew_Click() 'Saving Button
    Dim sonsat, ver As Long
    
    If TextBox1.Value = "" Then
        MsgBox "Please enter a Serial No.", vbExclamation, ""
        TextBox1.SetFocus
        Exit Sub
    End If
    If TextBox2.Value = "" Then
        MsgBox "Please enter Registration Date.", vbExclamation, ""
        TextBox2.SetFocus
        Exit Sub
    End If
    If TextBox3.Value = "" Then
        MsgBox "Please enter Pre-ART Number.", vbExclamation, ""
        TextBox3.SetFocus
        Exit Sub
    End If
    If TextBox10.Value = "" Then
        MsgBox "Please Update Complete address", vbExclamation, ""
        TextBox10.SetFocus
        Exit Sub
    End If
        
    If Not IsNumeric(TextBox1.Text) Then
        MsgBox "Please enter a Numeric Value.", vbExclamation, ""
        TextBox1.SetFocus
        Exit Sub
    End If
    For ver = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        
        If Cells(ver, "A") = TextBox1 Then
            MsgBox "This name is already registered !", vbInformation, ""
            TextBox3 = Empty 'Pre-ART Number Empty
            Exit Sub: End If: Next
            
            sonsat = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
            Call Main 'Progress Bar
            
            Cells(sonsat, 1) = TextBox1.Value
            Cells(sonsat, 2) = TextBox2.Text
            Cells(sonsat, 3) = TextBox3
            Cells(sonsat, 4) = TextBox4
            Cells(sonsat, 5) = TextBox5
            Cells(sonsat, 6) = TextBox6
            Cells(sonsat, 7) = TextBox7.Text
            Cells(sonsat, 8) = TextBox8.Text
            Cells(sonsat, 9) = TextBox9.Text
            Cells(sonsat, 10) = TextBox10.Text
            Cells(sonsat, 11) = TextBox11.Text
            Cells(sonsat, 12) = TextBox12.Text
            Cells(sonsat, 13) = TextBox13.Text
            Cells(sonsat, 14) = TextBox14
            Cells(sonsat, 15) = TextBox15.Value
            Cells(sonsat, 16) = TextBox16.Value
            Cells(sonsat, 17) = TextBox17
            Cells(sonsat, 18) = TextBox18
            Cells(sonsat, 19) = TextBox19.Value
            Cells(sonsat, 20) = TextBox20.Value
            Cells(sonsat, 21) = TextBox21
            Cells(sonsat, 22) = TextBox22
            Cells(sonsat, 23) = TextBox23
            Cells(sonsat, 24) = TextBox24
            Cells(sonsat, 25) = TextBox25
            Cells(sonsat, 26) = TextBox26
            Cells(sonsat, 27) = TextBox27
            Cells(sonsat, 28) = TextBox28
            Cells(sonsat, 29) = TextBox29
            Cells(sonsat, 30) = TextBox30
            Cells(sonsat, 31) = TextBox31
            Cells(sonsat, 32) = TextBox32
            Cells(sonsat, 33) = TextBox33
            Cells(sonsat, 34) = TextBox34
            Cells(sonsat, 35) = TextBox35
            Cells(sonsat, 36) = TextBox36
            Cells(sonsat, 37) = TextBox37
            Cells(sonsat, 38) = TextBox38
            Cells(sonsat, 39) = TextBox39
            Cells(sonsat, 40) = TextBox40
            Cells(sonsat, 41) = TextBox41
            Cells(sonsat, 42) = TextBox42
            Cells(sonsat, 43) = TextBox43
            Cells(sonsat, 44) = TextBox44
            Cells(sonsat, 45) = TextBox45
            Cells(sonsat, 46) = TextBox46.Value
            Cells(sonsat, 47) = TextBox47.Value
            Cells(sonsat, 48) = TextBox48
            Cells(sonsat, 49) = TextBox49.Text
            Cells(sonsat, 50) = TextBox50
            Cells(sonsat, 51) = TextBox51
            Cells(sonsat, 52) = TextBox52
            Cells(sonsat, 53) = TextBox53
            Cells(sonsat, 54) = TextBox54.Value
            Cells(sonsat, 55) = TextBox55
            Cells(sonsat, 56) = TextBox56.Value
            
            MsgBox "Registration is successful", vbApplicationModal, ""
            ListBox1.List = Sheets("Data").Range("A2:BD" & Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row).Value
            ListBox1.ListIndex = ListBox1.ListCount - 1
            TextBox101.Value = ListBox1.ListCount
        End Sub


Private Sub cmdUpdate_Click() 'Change Button
    Dim sonsat As Long
    
    If ListBox1.ListIndex = -1 Then
        MsgBox "Select the record", vbExclamation, ""
        Exit Sub
    End If
    lastrow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
   
    sonsat = ActiveCell.Row
    Cells(sonsat, 1) = TextBox1.Value
    Cells(sonsat, 2) = TextBox2.Text
    Cells(sonsat, 3) = TextBox3.Text
    Cells(sonsat, 4) = TextBox4.Text
    Cells(sonsat, 5) = TextBox5.Text
    Cells(sonsat, 6) = TextBox6.Text
    Cells(sonsat, 7) = TextBox7.Text
    Cells(sonsat, 8) = TextBox8.Text
    Cells(sonsat, 9) = TextBox9.Text
    Cells(sonsat, 10) = TextBox10.Text
    Cells(sonsat, 11) = TextBox11.Text
    Cells(sonsat, 12) = TextBox12.Text
    Cells(sonsat, 13) = TextBox13.Text
    Cells(sonsat, 14) = TextBox14
    Cells(sonsat, 15) = TextBox15.Value
    Cells(sonsat, 16) = TextBox16.Value
    Cells(sonsat, 17) = TextBox17
    Cells(sonsat, 18) = TextBox18
    Cells(sonsat, 19) = TextBox19.Value
    Cells(sonsat, 20) = TextBox20.Value
    Cells(sonsat, 21) = TextBox21
    Cells(sonsat, 22) = TextBox22
    Cells(sonsat, 23) = TextBox23
    Cells(sonsat, 24) = TextBox24
    Cells(sonsat, 25) = TextBox25
    Cells(sonsat, 26) = TextBox26
    Cells(sonsat, 27) = TextBox27
    Cells(sonsat, 28) = TextBox28
    Cells(sonsat, 29) = TextBox29
    Cells(sonsat, 30) = TextBox30
    Cells(sonsat, 31) = TextBox31
    Cells(sonsat, 32) = TextBox32
    Cells(sonsat, 33) = TextBox33
    Cells(sonsat, 34) = TextBox34
    Cells(sonsat, 35) = TextBox35
    Cells(sonsat, 36) = TextBox36
    Cells(sonsat, 37) = TextBox37
    Cells(sonsat, 38) = TextBox38
    Cells(sonsat, 39) = TextBox39
    Cells(sonsat, 40) = TextBox40
    Cells(sonsat, 41) = TextBox41
    Cells(sonsat, 42) = TextBox42
    Cells(sonsat, 43) = TextBox43
    Cells(sonsat, 44) = TextBox44
    Cells(sonsat, 45) = TextBox45
    Cells(sonsat, 46) = TextBox46.Value
    Cells(sonsat, 47) = TextBox47.Value
    Cells(sonsat, 48) = TextBox48
    Cells(sonsat, 49) = TextBox49
    Cells(sonsat, 50) = TextBox50
    Cells(sonsat, 51) = TextBox51
    Cells(sonsat, 52) = TextBox52
    Cells(sonsat, 53) = TextBox53
    Cells(sonsat, 54) = TextBox54.Value
    Cells(sonsat, 55) = TextBox55
    Cells(sonsat, 56) = TextBox56.Value
    
    Call Main 'Progress Bar
    MsgBox "Record has been updated", vbApplicationModal, ""
    ListBox1.List = Sheets("Data").Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).Value
End Sub




Private Sub ClearData_Click() 'ClearData BUTTON
    Dim del As Control
    Call Main 'Progress Bar
    For Each del In UserForm1.Controls
        If TypeName(del) = "TextBox" Or TypeName(del) = "ComboBox" Then
            del.Text = Empty
        End If
        Next del
        
        ListBox1.Clear
        Label15.Caption = ""
        
    End Sub


Private Sub cmdSearch_Click() 'Search Button
Dim sat, s As Long


Sheets("Data").Activate
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
OptionButton1.Value = True
TextBox102.Value = Empty
If TextBox100.Text = "" Then
MsgBox "Please enter a value", vbExclamation, ""
TextBox100.SetFocus
Exit Sub: End If


If ComboBox1.Text = "" Or ComboBox1.Text = "-" Then
MsgBox "Choose a Filter Field", vbExclamation, ""
ComboBox1.SetFocus
Exit Sub: End If


Call Main 'Progress Bar


Select Case ComboBox1.Text


'Search with Name
Case "Name"
ActiveSheet.AutoFilterMode = False
ListBox1.Clear
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=9, Criteria1:=TextBox100.Text & "*", Operator:=xlAnd
Sheets("FilteredData").Cells.Clear


If ActiveSheet.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1 Then
GoTo here:
Else
ActiveSheet.Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Sheets("FilteredData").Range("A2")
End If
Sheets("FilteredData").Columns.AutoFit
ListBox1.List = Sheets("FilteredData").Range("A2:BD" & Sheets("FilteredData").Cells(Rows.Count, 1).End(xlUp).Row).Value
here:
ActiveSheet.AutoFilterMode = False
Call Clear


' ART Status
Case "ART Status"
ActiveSheet.AutoFilterMode = False
ListBox1.Clear
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=25, Criteria1:=TextBox100.Text & "*", Operator:=xlAnd
Sheets("FilteredData").Cells.Clear


If ActiveSheet.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1 Then
GoTo here2:
Else
ActiveSheet.Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Sheets("FilteredData").Range("A2")
End If
Sheets("FilteredData").Columns.AutoFit
ListBox1.List = Sheets("FilteredData").Range("A2:BD" & Sheets("FilteredData").Cells(Rows.Count, 1).End(xlUp).Row).Value
here2:
ActiveSheet.AutoFilterMode = False
Call Clear


' Pre-ART Status
Case "Pre-ART Status"
ActiveSheet.AutoFilterMode = False
ListBox1.Clear
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=22, Criteria1:=TextBox100.Text & "*", Operator:=xlAnd
Sheets("FilteredData").Cells.Clear


If ActiveSheet.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1 Then
GoTo here2:
Else
ActiveSheet.Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Sheets("FilteredData").Range("A2")
End If
Sheets("FilteredData").Columns.AutoFit
ListBox1.List = Sheets("FilteredData").Range("A2:BD" & Sheets("FilteredData").Cells(Rows.Count, 1).End(xlUp).Row).Value
here3:
ActiveSheet.AutoFilterMode = False
Call Clear


'ART Number
Case "ART No"
ActiveSheet.AutoFilterMode = False
ListBox1.Clear
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=23, Criteria1:=TextBox100.Text & "*", Operator:=xlAnd
Sheets("FilteredData").Cells.Clear


If ActiveSheet.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1 Then
GoTo here3:
Else
ActiveSheet.Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Sheets("FilteredData").Range("A2")
End If
Sheets("FilteredData").Columns.AutoFit
ListBox1.List = Sheets("FilteredData").Range("A2:BD" & Sheets("FilteredData").Cells(Rows.Count, 1).End(xlUp).Row).Value
here4:
ActiveSheet.AutoFilterMode = False
Call Clear


' Pre-ART Number
Case "Pre-ART No"
ActiveSheet.AutoFilterMode = False
ListBox1.Clear
Select Case SearchSection.ListIndex
Case "0"
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=3, Criteria1:="=" & TextBox100.Text
Case "1"
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=3, Criteria1:="<" & TextBox100.Text
Case "2"
ActiveSheet.Range("A1:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=3, Criteria1:=">" & TextBox100.Text
End Select


Sheets("FilteredData").Cells.Clear


If ActiveSheet.Range("A1").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1 Then
GoTo here5:
Else
ActiveSheet.Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy _
        Destination:=Sheets("FilteredData").Range("A2")
End If
Sheets("FilteredData").Columns.AutoFit
ListBox1.List = Sheets("FilteredData").Range("A2:BD" & Sheets("FilteredData").Cells(Rows.Count, 1).End(xlUp).Row).Value
here5:
ActiveSheet.AutoFilterMode = False
Call Clear


End Select
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With


Label15.Caption = ListBox1.ListCount
End Sub


Private Sub cmdClear_Click() 'Clear Search Textbox Button
TextBox100.Text = "": ComboBox1.Value = ""
ListBox1.Clear
Label15.Caption = ""
End Sub


Private Sub cmdClose_Click() 'Close Button
Unload Me
End Sub


Private Sub CopyRecord_Click()
    
 Dim Litem As Long, LbRows As Long, LbCols As Long
 Dim bu As Boolean
 Dim Lbloop As Long, Lbcopy As Long
  
 LbRows = ListBox1.ListCount - 1
 LbCols = ListBox1.ColumnCount - 1
   
    For Litem = 0 To LbRows
    If ListBox1.Selected(Litem) = True Then
          bu = True
          Exit For
    End If
    Next


    If bu = True Then
    With Sheets("SelectedData").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      
            For Litem = 0 To LbRows
                If ListBox1.Selected(Litem) = True Then 'Row selected
                  'Increment variable for row transfer range
                  Lbcopy = Lbcopy + 1
            For Lbloop = 0 To LbCols
                       'Transfer selected row to relevant row of transfer range
            .Cells(Lbcopy, Lbloop + 1) = ListBox1.List(Litem, Lbloop)
                       
           Next Lbloop
                End If
            Next
            For m = 0 To LbCols
                With Sheets("SelectedData").Cells(Rows.Count, 1).End(xlUp).Offset(0, m).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = 23
        End With
Next
        End With
        
    Else
         MsgBox "Nothing chosen", vbCritical
         Exit Sub
    End If
MsgBox "The Selected Data are Copied.", vbInformation
Sheets("SelectedData").Select


End Sub


Private Sub FillList_Click() 'To fill the ListBox
            ListBox1.ColumnWidths = "0;60;55;0;0;0;0;0;85;160;75;75;0;0;0;20;40;0;0;0;0;85;0;0;85;0;0;0;0;0;0;50;80;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0" 'COLUMN WIDTHS OF LISTBOX
            ListBox1.ColumnCount = 56 'Column Count Of Listbox
            ListBox1.List = Sheets("Data").Range("A2:BD" & Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row).Value
            ListBox1.ListIndex = -1
            TextBox101.Value = ListBox1.ListCount
End Sub


Private Sub ListBox1_Click()
Dim say, lastrow As Long, a As Byte
'ListBox1.MultiSelect = 0
OptionButton1.Value = True
For a = 0 To 54
Controls("textbox" & a + 1) = ListBox1.Column(a)
Next
TextBox55.Value = ListBox1.Column(55)


lastrow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Data").Activate
Sheets("Data").Range("A2:A" & lastrow).Find(What:=ListBox1.Value, LookIn:=xlValues, LookAt:=xlWhole).Activate


say = ActiveCell.Row
TextBox102.Value = say
Sheets("Data").Range("A" & say & ":BD" & say).Select


End Sub


Private Sub OptionButton1_Click()
ListBox1.MultiSelect = 0
End Sub


Private Sub OptionButton2_Click()
ListBox1.ListIndex = -1
ListBox1.MultiSelect = 1
End Sub


Private Sub OptionButton3_Click()
ListBox1.ListIndex = -1
ListBox1.MultiSelect = 2
End Sub


Private Sub SpinButton1_SpinDown()
On Error Resume Next
If ListBox1.ListIndex = ListBox1.ListCount - 1 Then Exit Sub
With Me.ListBox1
        .ListIndex = .ListIndex + 1
    End With
 End Sub


Private Sub SpinButton1_SpinUp()
On Error Resume Next
If ListBox1.ListIndex = 0 Then Exit Sub


With Me.ListBox1
        .ListIndex = .ListIndex - 1
    End With
    End Sub


Private Sub TextBox1_Change() ' Serial Number
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox1.Text) And TextBox1.Text <> "" Then
  If Len(TextBox1.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox1.Text = Abs(Round(Left(TextBox1.Text, Len(TextBox1.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox1.Text = ""
  End If
ElseIf TextBox1.Text <> "" Then
  If TextBox1.Text = 0 Then
    'Ensure Not Zero
      TextBox1.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox1.Text = Abs(Round(TextBox1.Text, 0))
  End If
End If


End Sub


Private Sub TextBox15_Change() 'Aadhar Card


'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox15.Text) And TextBox15.Text <> "" Then
  If Len(TextBox15.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox15.Text = Abs(Round(Left(TextBox15.Text, Len(TextBox15.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox15.Text = ""
  End If
ElseIf TextBox15.Text <> "" Then
  If TextBox15.Text = 0 Then
    'Ensure Not Zero
      TextBox15.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox15.Text = Abs(Round(TextBox15.Text, 0))
  End If
End If
End Sub


Private Sub TextBox19_Change() ' Baseline CD4 Count
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox19.Text) And TextBox19.Text <> "" Then
  If Len(TextBox19.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox19.Text = Abs(Round(Left(TextBox19.Text, Len(TextBox19.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox19.Text = ""
  End If
ElseIf TextBox19.Text <> "" Then
  If TextBox19.Text = 0 Then
    'Ensure Not Zero
      TextBox19.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox19.Text = Abs(Round(TextBox19.Text, 0))
  End If
End If
End Sub


Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) ' Date of Registrations
     If Not IsDate(TextBox2.Text) Then
         TextBox2.BackColor = &HFF& ' change the color of the textbox
         
         ' setting Cancel to True means the user cannot leave this textbox
         ' until the value is in the proper date format
         
     Else
          TextBox2.BackColor = &H80000005 ' change color of the textbox
     End If
End Sub


Private Sub TextBox20_Change() ' Latest CD4 Count
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox20.Text) And TextBox20.Text <> "" Then
  If Len(TextBox20.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox20.Text = Abs(Round(Left(TextBox20.Text, Len(TextBox20.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox20.Text = ""
  End If
ElseIf TextBox20.Text <> "" Then
  If TextBox20.Text = 0 Then
    'Ensure Not Zero
      TextBox20.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox20.Text = Abs(Round(TextBox20.Text, 0))
  End If
End If
End Sub


Private Sub TextBox24_Exit(ByVal Cancel As MSForms.ReturnBoolean) ' Date of Start ART
     If Not IsDate(TextBox24.Text) Then
         TextBox24.BackColor = &HFF& ' change the color of the textbox
         MsgBox "Check the Date value"
         ' setting Cancel to True means the user cannot leave this textbox
         ' until the value is in the proper date format
         Cancel = True
     Else
          TextBox24.BackColor = &H80000005 ' change color of the textbox
     End If
End Sub


Private Sub TextBox28_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'Date of Transfer Out
     If Not IsDate(TextBox28.Text) Then
         TextBox28.BackColor = &HFF& ' change the color of the textbox
         
         ' setting Cancel to True means the user cannot leave this textbox
         ' until the value is in the proper date format
         Cancel = True
     Else
          TextBox28.BackColor = &H80000005 ' change color of the textbox
     End If
End Sub


Private Sub TextBox29_Change() ' Drop Down for Transfer Out ART Center Code
If TextBox29.ListIndex = -1 And IsError(Application.Match(TextBox29, ARTCode, 0)) Then
        Set SD = CreateObject("Scripting.Dictionary")
        bul = TextBox29 & "*"
        For Each c In ARTCode:
            If c Like bul Then SD(c) = ""
        Next c
        TextBox29.List = SD.keys
        TextBox29.DropDown
            Else
        Evn = TextBox29
        If Evn = "" Then Exit Sub
        Set d2 = CreateObject("Scripting.Dictionary")
             
        If Val(Application.Version) > 10 Then SendKeys "{f4}"
        
    End If
End Sub


Private Sub TextBox32_Change() ' Drop Down for Drugs
If TextBox32.ListIndex = -1 And IsError(Application.Match(TextBox32, Drugs, 0)) Then
        Set SD = CreateObject("Scripting.Dictionary")
        bul = TextBox32 & "*"
        For Each c In Drugs:
            If c Like bul Then SD(c) = ""
        Next c
        TextBox32.List = SD.keys
        TextBox32.DropDown
            Else
        Evn = TextBox32
        If Evn = "" Then Exit Sub
        Set d2 = CreateObject("Scripting.Dictionary")
             
        If Val(Application.Version) > 10 Then SendKeys "{f4}"
        
    End If
End Sub






Private Sub TextBox46_Change() ' Total Children needed testing
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox46.Text) And TextBox46.Text <> "" Then
  If Len(TextBox46.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox46.Text = Abs(Round(Left(TextBox46.Text, Len(TextBox46.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox46.Text = ""
  End If
ElseIf TextBox46.Text <> "" Then
  If TextBox46.Text = 0 Then
    'Ensure Not Zero
      TextBox46.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox46.Text = Abs(Round(TextBox46.Text, 0))
  End If
End If
End Sub


Private Sub TextBox47_Change() ' Children tested
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox47.Text) And TextBox47.Text <> "" Then
  If Len(TextBox47.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox47.Text = Abs(Round(Left(TextBox47.Text, Len(TextBox47.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox47.Text = ""
  End If
ElseIf TextBox47.Text <> "" Then
  If TextBox47.Text = 0 Then
    'Ensure Not Zero
      TextBox47.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox47.Text = Abs(Round(TextBox47.Text, 0))
  End If
End If
End Sub


Private Sub TextBox54_Change() ' Baseline Viral Load
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox54.Text) And TextBox54.Text <> "" Then
  If Len(TextBox54.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox54.Text = Abs(Round(Left(TextBox54.Text, Len(TextBox54.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox54.Text = ""
  End If
ElseIf TextBox54.Text <> "" Then
  If TextBox54.Text = 0 Then
    'Ensure Not Zero
      TextBox54.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox54.Text = Abs(Round(TextBox54.Text, 0))
  End If
End If
End Sub


Private Sub TextBox56_Change() ' Latest Viral Load
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers (excluding 0)


If Not IsNumeric(TextBox56.Text) And TextBox56.Text <> "" Then
  If Len(TextBox56.Text) > 1 Then
    'Remove Added Non-Numerical Character from Number
      TextBox56.Text = Abs(Round(Left(TextBox56.Text, Len(TextBox56.Text) - 1), 0))
  Else
    'Delete Single Non-Numerical Character
      TextBox56.Text = ""
  End If
ElseIf TextBox56.Text <> "" Then
  If TextBox56.Text = 0 Then
    'Ensure Not Zero
      TextBox56.Text = ""
  Else
    'Ensure Positive and No Decimals
      TextBox56.Text = Abs(Round(TextBox56.Text, 0))
  End If
End If
End Sub


Private Sub UserForm_Initialize()
Sheets("Data").Activate
ListBox1.ColumnWidths = "0;60;55;0;0;0;0;0;85;160;75;75;0;0;0;20;40;0;0;0;0;85;0;0;85;0;0;0;0;0;0;50;80;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0"         'Column Widths Of Listbox
ListBox1.ColumnCount = 56                                                   'Column Count Of Listbox
ListBox1.List = Sheets("Data").Range("A2:BD" & Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row).Value


'Search ComboBox
With ComboBox1
.AddItem "Pre-ART No"
.AddItem "Pre-ART Status"
.AddItem "ART No"
.AddItem "Name"
.AddItem "ART Status"
End With


'Transfer-In or Not?
With TextBox4
.AddItem "Pre-ART"
.AddItem "On-ART"
.AddItem "No"
End With


' Transfer In ART Center Code
Dim cLoc As Range
Dim ws As Worksheet
Set ws = Worksheets("ARTC")


For Each cLoc In ws.Range("ARTCode")
  With Me.TextBox5
     .AddItem cLoc.Value
  End With
Next cLoc


'Sex ComboBox
With TextBox17
.AddItem "Female"
.AddItem "Male"
.AddItem "TS/TG"
End With


' Risk Factor (Typology)
With TextBox18
.AddItem "Heterosexual"
.AddItem "FSW"
.AddItem "MSM"
.AddItem "IDU"
.AddItem "TG"
.AddItem "Migrant"
.AddItem "Trucker"
.AddItem "Mother to Child"
.AddItem "Blood Transfusion"
.AddItem "Probable Unsafe Injection"
End With


' Pre ART Status
With TextBox22
.AddItem "Alive in Pre-ART"
.AddItem "Died"
.AddItem "LFU before 31 Dec 2010"
.AddItem "LFU after 1 Jan 2011"
.AddItem "Opted Out"
.AddItem "Transfer Out"
.AddItem "Initiated on ART"
.AddItem "Eligible but not Initiated on ART"
End With


' On ART Status
With TextBox25
.AddItem "Alive on ART"
.AddItem "Died"
.AddItem "LFU"
.AddItem "Stopped"
.AddItem "MIS"
.AddItem "Transfer out"
.AddItem "Opted out"
End With


' ART Adherence
With TextBox33
.AddItem "Good >95%"
.AddItem "Average 80 - 95%"
.AddItem "Poor <80%"
End With


' 4S Screening
With TextBox34
.AddItem "4S Ve"
.AddItem "4S -Ve"
.AddItem "Not Done"
End With


' IPT Status
With TextBox35
.AddItem "Not Applicable"
.AddItem "Initiated on IPT"
.AddItem "Restarted"
.AddItem "Stopped/Restarted"
.AddItem "Completed"
End With


' Referred for TB testing current month
With TextBox36
.AddItem "Yes"
.AddItem "No"
End With


' TB Diagnosis
With TextBox37
.AddItem "Pulmonary TB (MC)"
.AddItem "Pulmonary TB (CD)"
.AddItem "Extra Pulmonary TB(MC)"
.AddItem "Extra Pulmonary TB(CD)"
End With


' TB treatment status
With TextBox38
.AddItem "Initiated on ATT"
.AddItem "On ATT"
.AddItem "ATT Stopped"
.AddItem "ATT Completed"
.AddItem "Not Applicable"
End With


' RIF Status
With TextBox40
.AddItem "Yes"
.AddItem "No"
End With


' ANC Status
With TextBox41
.AddItem "Yes"
.AddItem "No"
End With


' ANC Status
With TextBox42
.AddItem "Yes"
.AddItem "No"
End With


' EID
With TextBox43
.AddItem "Yes"
.AddItem "No"
End With


' Spouse Status
With TextBox44
.AddItem "Positive"
.AddItem "Negative"
.AddItem "Not Known"
.AddItem "Not Done"
.AddItem "NA"
End With


' Spouse eligible for testing
With TextBox45
.AddItem "Yes"
.AddItem "No"
End With


' Whether Linked to LAC/LAC +
With TextBox48
.AddItem "Yes"
.AddItem "No"
End With


' LAC Status
With TextBox50
.AddItem "Alive on ART"
.AddItem "Died"
.AddItem "LFU"
.AddItem "MIS"
.AddItem "Referred back"
.AddItem "Pre-ART Care"
End With


' Referred To SACEP
With TextBox51
.AddItem "Yes"
.AddItem "No"
End With
'**********************************************
With SearchSection
.AddItem "="
.AddItem "<"
.AddItem ">"
End With


SearchSection.ListIndex = 0
TextBox101.Value = ListBox1.ListCount
TextBox102.Value = ""


With lblDone
        .Top = lblRemain.Top + 1
        .Left = lblRemain.Left + 1
        .Height = lblRemain.Height - 2
        .Width = 0
    End With
lblPct.Visible = False
OptionButton1.Value = True


Drugs = Application.Transpose(Range("Drugs")) 'Drop Down for Drugs
   
    Set SD = CreateObject("Scripting.Dictionary")
    For Each x In Drugs
        SD(x) = ""
    Next x
    TextBox32.List = SD.keys


ARTCode = Application.Transpose(Range("ARTCode")) 'Drop Down for Transfer Out ART Center Code
   
    Set SD = CreateObject("Scripting.Dictionary")
    For Each x In ARTCode
        SD(x) = ""
    Next x
    TextBox29.List = SD.keys
    
 
    Dim raaj 'Drop Down for State, District and SubDistricts
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Lists")
    For Each r In .Range("a2", .Range("a65536").End(xlUp))
        If Not IsEmpty(r) And Not dic.exists(r.Value) Then
            dic.Add r.Value, Nothing
        End If
    Next
End With
raaj = dic.keys
Me.TextBox13.List = raaj


End Sub


Sub Main() ' PROGRESS BAR CODES
Dim i, tot As Long
tot = 5000
For i = 1 To tot
If i Mod 5 = 0 Then
ProgressBar i / tot
End If
Next i
lblDone.Width = 0
lblPct.Visible = False
End Sub
Sub ProgressBar(PctDone As Single) ' PROGRESS BAR
    lblDone.Width = PctDone * (lblRemain.Width - 2)
    lblPct.Visible = True
    lblPct.Caption = Format(PctDone, "0%")
    DoEvents
 End Sub
Sub Clear() ' Clear all the text boxes
Dim n As Byte
For n = 1 To 54 ' Clear textboxes(1-55)
Controls("textbox" & n) = Empty
Next
TextBox55 = Empty: TextBox56 = Empty
End Sub
Private Sub TextBox13_Change() ' Drop Down for State
Me.TextBox12.Clear: Me.TextBox12.Clear
Set dic = CreateObject("Scripting.dictionary")
    With Sheets("Lists")
        For Each r In .Range("a2", .Range("a65536").End(xlUp))
            If r = Me.TextBox13.Value Then
                If Not dic.exists(r.Offset(, 1).Value) Then
                    Me.TextBox12.AddItem r.Offset(, 1)
                    dic.Add r.Offset(, 1).Value, Nothing
                End If
            End If
        Next
    End With
    With Me.TextBox12
        If .ListCount = 1 Then .ListIndex = 0
    End With
End Sub
Private Sub TextBox12_Change() ' Drop Down for District
Dim raaj
Me.TextBox11.Clear
With Sheets("Lists")
    For Each r In .Range("a2", .Range("a65536").End(xlUp))
        If r = Me.TextBox13.Value And r.Offset(, 1) = Me.TextBox12.Value Then
            raaj = r.Offset(, 2) & Chr(32) & r.Offset(, 3)
                Me.TextBox11.AddItem raaj
        End If
    Next
End With
With Me.TextBox11
    If .ListCount = 1 Then .ListIndex = 0
End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Moving Rows Up (Scroll) To Defined Row Number for Viewing
Replies
6
Views
206
Ark68
A
E
  • Question
Trying to use a month name in my VLookup
Replies
2
Views
147
Eric Penfold
E
tourless
  • Question
Capture and remove last two in a string
Replies
3
Views
492
duggie33
D
S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
176
shand
S
E
  • Solved
The range seems to not work
Replies
5
Views
135
Eric Penfold
E

Forum statistics

Threads
1,215,069
Messages
6,122,959
Members
449,096
Latest member
Anshu121

Share this page

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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