The program has a startup menu. Which pops up immediately. When I click on the "Membership" or "Transactions" menu items an appropriate userform opens up for the end-user to add transactions, and in the case of members, search and add or delete members.
This program started slowing down each time I was adding a transaction (>350 as of now) and members (>700 as of now). But once the userform pops, it works pretty fast.
Now it takes upwards of 7 minutes for the userform to popup. To confirm my suspicion, I deleted all but a few of the transactions and sure enough, the form popped up in less than 10 seconds. I deleted the members and similar improvements.
I am suspecting these two codes are causing the slow down.
Any help how I can improve my code to make the userforms open up faster will be greatly appreciated.
TIA, JCK
This program started slowing down each time I was adding a transaction (>350 as of now) and members (>700 as of now). But once the userform pops, it works pretty fast.
Now it takes upwards of 7 minutes for the userform to popup. To confirm my suspicion, I deleted all but a few of the transactions and sure enough, the form popped up in less than 10 seconds. I deleted the members and similar improvements.
I am suspecting these two codes are causing the slow down.
Any help how I can improve my code to make the userforms open up faster will be greatly appreciated.
TIA, JCK
Code:
'Membership userform
'***********Minimize button
Private Declare Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
'***********
Public NextAddress, pRecID, pFname, pLname, pTeamName, pTeamCoach As String
Public Flag, modFlag As Boolean
Dim LR, LRrow1, LRrow2 As Long
Dim x As Integer
Dim hTel As Integer
Dim wTel As Integer
Dim cTel As Integer
Dim MyData As Range
Dim c As Range
Dim rFound As Range
Dim r As Long
Dim rng As Range
Const frmMax As Long = 520
Const frmHt As Long = 420
Const frmWidth As Long = 400
Dim sFileName As String 'image name
Dim oCtrl As MSForms.Control
Private Sub UserForm_Initialize()
'On Error GoTo 0
Call FormatUserForm(Me.Caption) 'Minimize buttons
Application.ScreenUpdating = False
Sheets("Members").Activate
Set MyData = Sheet1.Range("a5").CurrentRegion 'data range
With Me
'.Caption = "Crescenta Valley Chapter - Search Database"
'if I turn the caption on the MINIMIZE button is NOT working
.Height = frmHt
.Width = frmWidth
End With
'this will clear all contents from LkupLists sheet
Sheets("LkupLists").Cells.ClearContents
'Enter column headings
Sheets("LkupLists").Cells(1, 1) = "SerialNo"
Sheets("LkupLists").Cells(1, 2) = "FullName"
Sheets("LkupLists").Cells(1, 3) = "LastName"
Sheets("LkupLists").Cells(1, 4) = "TelNo"
Sheets("LkupLists").Cells(1, 5) = ""
Sheets("LkupLists").Cells(1, 6) = "SerialNo"
Sheets("LkupLists").Cells(1, 7) = "FullName"
Sheets("LkupLists").Cells(1, 8) = "LastName"
Sheets("LkupLists").Cells(1, 9) = "TelNo"
Sheets("LkupLists").Cells(1, 10) = ""
Sheets("LkupLists").Cells(1, 11) = "SerialNo"
Sheets("LkupLists").Cells(1, 12) = "FullName"
Sheets("LkupLists").Cells(1, 13) = "LastName"
Sheets("LkupLists").Cells(1, 14) = "TelNo"
Sheets("LkupLists").Cells(1, 15) = ""
'****************
'CellActive
LRrow1 = Range("C" & Rows.Count).End(xlUp).Row 'Get Data Rows
LRrow2 = Range("A" & Rows.Count).End(xlUp).Row + 1
'Start Populating LkupList columns
Sheets("LkupLists").Select
For x = 2 To LRrow1
hTel = Len(Sheets("Members").Cells(x, 12).Value)
wTel = Len(Sheets("Members").Cells(x, 13).Value)
cTel = Len(Sheets("Members").Cells(x, 14).Value)
'
'Populate LkupList and sort by RecID
'
Cells(LRrow2, 1) = Sheets("Members").Cells(x, 3).Value 'SerialNo
'FullName by FORMULA--CONCATENATE(Members!D2," ",Members!F2)
Cells(LRrow2, 2) = "=CONCATENATE(Members!D" & x & ","" "",Members!F" & x & ")"
Cells(LRrow2, 3) = Sheets("Members").Cells(x, 6).Value 'LastName
'***********
'Populate Tel#s
'
If cTel > 0 Then
Cells(LRrow2, 4) = Sheets("Members").Cells(x, 14).Value 'Cell No
Else
If wTel > 0 Then
Cells(LRrow2, 4) = Sheets("Members").Cells(x, 13).Value 'Work No
Else
Cells(LRrow2, 4) = Sheets("Members").Cells(x, 12).Value 'Home No
End If
End If
'***********
'Populate LkupList and sort by Full Name
'
Cells(LRrow2, 6) = Sheets("Members").Cells(x, 3).Value 'SerialNo
Cells(LRrow2, 7) = "=CONCATENATE(Members!D" & x & ","" "",Members!F" & x & ")"
Cells(LRrow2, 8) = Sheets("Members").Cells(x, 6).Value 'LastName
'
'***********
'Tel#s
'
If cTel > 0 Then
Cells(LRrow2, 9) = Sheets("Members").Cells(x, 14).Value 'Cell No
Else
If wTel > 0 Then
Cells(LRrow2, 9) = Sheets("Members").Cells(x, 13).Value 'Work No
Else
Cells(LRrow2, 9) = Sheets("Members").Cells(x, 12).Value 'Home No
End If
End If
'***********
'Populate LkupList and sort by Last Name
'
Cells(LRrow2, 11) = Sheets("Members").Cells(x, 3).Value 'SerialNo
Cells(LRrow2, 12) = "=CONCATENATE(Members!D" & x & ","" "",Members!F" & x & ")"
Cells(LRrow2, 13) = Sheets("Members").Cells(x, 6).Value 'LastName
'***********
'Tel#
'
If cTel > 0 Then
Cells(LRrow2, 14) = Sheets("Members").Cells(x, 14).Value 'Cell No
Else
If wTel > 0 Then
Cells(LRrow2, 14) = Sheets("Members").Cells(x, 13).Value 'Work No
Else
Cells(LRrow2, 14) = Sheets("Members").Cells(x, 12).Value 'Home No
End If
End If
'***********
'
LRrow2 = LRrow2 + 1
Next x
'****************
'This will determine the range count for each sort field.....
LR = Range("D" & Rows.Count).End(xlUp).Row
'
Sheets("LkupLists").Activate
'SortRecords
'original code
With Sheets("LkupLists")
'SerialNo
.Range("A2:D" & LR).Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlGuess, _
ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'FullName
.Range("F2:I" & LR).Sort key1:=Range("G2"), order1:=xlAscending, Header:=xlGuess, _
ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'LastName
.Range("K2:N" & LR).Sort key1:=Range("M2"), Key2:=Range("L2"), order1:=xlAscending, Header:=xlGuess, _
ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'
'create the named ranges
ActiveWorkbook.Names.Add Name:="SerialNo", RefersTo:= _
"=OFFSET(LkupLists!$A$2,0,0,COUNTA(LkupLists!$A:$A)-1,1)"
ActiveWorkbook.Names.Add Name:="FullName", RefersTo:= _
"=OFFSET(LkupLists!$g$2,0,0,COUNTA(LkupLists!$g:$g)-1,1)"
ActiveWorkbook.Names.Add Name:="FamilyName", RefersTo:= _
"=OFFSET(LkupLists!$m$2,0,0,COUNTA(LkupLists!$m:$m)-1,1)"
'
Me.ComboBoxMemFullName.RowSource = "FullName"
Me.ComboBoxMemSerialNo.RowSource = "SerialNo"
Me.ComboBoxMemLName.RowSource = "FamilyName"
'
'
Sheets("Members").Activate
Application.ScreenUpdating = True
End With
End Sub
'**************Minimize button
Sub FormatUserForm(UserFormCaption As String)
'On Error GoTo 0
Dim hWnd As Long
Dim exLong As Long
hWnd = FindWindowA(vbNullString, UserFormCaption)
exLong = GetWindowLongA(hWnd, -16)
If (exLong And &H20000) = 0 Then
SetWindowLongA hWnd, -16, exLong Or &H20000
Else
End If
End Sub
'**************
Private Sub UserForm_Activate()
'On Error GoTo 0
Me.ComboBoxMemFullName.SetFocus
End Sub
Private Sub UserForm_QueryClose _
(Cancel As Integer, CloseMode As Integer)
' Prevents use of the Close button
If CloseMode = vbFormControlMenu Then
MsgBox "The Close button is disabled, please click Cancel."
Cancel = True
End If
End Sub
Private Sub ComboBoxMemFullName_Click()
'When you click on a name in the drop down box "Full Name"
'popluates the textboxes
Flag = True
Me.ComboBoxMemSerialNo.ListIndex = -1
Me.ComboBoxMemLName.ListIndex = -1
Flag = False
End Sub
Private Sub ComboBoxMemSerialNo_Click()
'When you click on a name in the drop down box "Record ID"
'popluates the textboxes
Flag = True
Me.ComboBoxMemFullName.ListIndex = -1
Me.ComboBoxMemLName.ListIndex = -1
Flag = False
End Sub
Private Sub ComboBoxMemLName_Click()
'When you click on a name in the drop down box "Last Names"
Flag = True
Me.ComboBoxMemFullName.ListIndex = -1
Me.ComboBoxMemSerialNo.ListIndex = -1
Flag = False
End Sub
Private Sub ComboBoxMemSerialNo_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
With Me
.ComboBoxMemFullName.ListIndex = -1
.ComboBoxMemLName.ListIndex = -1
'this is to reset the Height and Width of the form
.Height = frmHt
.Width = frmWidth
End With
End Sub
Private Sub ComboBoxMemFullName_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
With Me
.ComboBoxMemFullName.ListIndex = -1
.ComboBoxMemLName.ListIndex = -1
'this is to reset the Height and Width of the form
.Height = frmHt
.Width = frmWidth
End With
End Sub
Private Sub ComboBoxMemLName_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
With Me
.ComboBoxMemFullName.ListIndex = -1
.ComboBoxMemLName.ListIndex = -1
'this is to reset the Height and Width of the form
.Height = frmHt
.Width = frmWidth
End With
End Sub
Private Sub CommandButtonPrevious_Click()
'On Error GoTo 0
If TextBoxMemFullName.Value = "" Then Exit Sub
Flag = True
Call FindAddress
With Me
.CommandButtonModify.Enabled = True
If Sheet1.Range(NextAddress).Offset(-2, 0).Address = "$A$1" Then Exit Sub
If Sheet1.Range(NextAddress).Address = "$C:$" & LR Then Exit Sub
.TextBoxMemSerialNo.Value = Sheet1.Range(NextAddress).Offset(-2, 0).Value
Call TxtBxMemSerialNo
.CommandButtonNext.Enabled = False 'disable the button True
.CommandButtonPrevious.Enabled = False 'disable the button True
End With
Flag = False
End Sub
Private Sub CommandButtonNext_Click()
'On Error GoTo 0
If TextBoxMemFullName.Value = "" Then Exit Sub
Flag = True
Call FindAddress
With Me
.CommandButtonModify.Enabled = True
If Sheet1.Range(NextAddress).Offset(0, 0).Address = "$AV$" & LR + 1 Then Exit Sub
.TextBoxMemSerialNo.Value = Sheet1.Range(NextAddress).Offset(0, 0).Value
Call TxtBxMemSerialNo
.CommandButtonNext.Enabled = False 'disable the button True
.CommandButtonPrevious.Enabled = False 'disable the button True
End With
Flag = False
End Sub
Private Sub CommandButtonAddMember_Click()
'command button "Go To Add New"
BackToForm = "Main"
frmMain.Hide 'show this back when debugging is over
frmAddMember.Show False
End Sub
Private Sub CommandButtonAddTranx_Click()
BackToForm = "Main"
frmMain.Hide
frmTransaction.Show False
End Sub
Private Sub CommandButtonModify_Click()
'On Error GoTo 0
Application.ScreenUpdating = False
modFlag = True
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
'write changes to the database
c.Offset(0, -45).Value = Me.TextBoxMemSerialNo.Value
c.Offset(0, -42).Value = Me.TextBoxMemLName.Value
c.Offset(0, -44).Value = Me.TextBoxMemFName.Value
c.Offset(0, -41).Value = Me.TextBoxMemStreet.Value
c.Offset(0, -39).Value = Me.TextBoxMemCity.Value
c.Offset(0, -38).Value = Me.TextBoxMemState.Value
c.Offset(0, -37).Value = Me.TextBoxMemZip.Value
c.Offset(0, -36).Value = Me.TextBoxMemTelHome.Value
c.Offset(0, -35).Value = Me.TextBoxMemTelWork.Value
c.Offset(0, -34).Value = Me.TextBoxMemTelCell.Value
c.Offset(0, -31).Value = Me.TextBoxMemEmail.Value
'restore Form
With Me
.CommandButtonModify.Enabled = False
.CommandButtonDelete.Enabled = False
.CommandButtonAddMember.Enabled = True
Call ClearControls
.Height = frmHt
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("A8").AutoFilter
modFlag = False
Application.ScreenUpdating = True
'On Error GoTo 0
End Sub
Private Sub CommandButtonDelete_Click()
'On Error GoTo 0
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
'new code
'
'CellActive
'
c.Offset(0, -47).Value = "ToBeDeleted"
'restore form settings
With Me
.CommandButtonModify.Enabled = False 'prevent accidental use
.CommandButtonDelete.Enabled = False 'prevent accidental use
.CommandButtonNext.Enabled = False
.CommandButtonPrevious.Enabled = False
.CommandButtonAddMember.Enabled = True 'restore use
'clear form
Call ClearControls
End With
Case vbNo
Exit Sub 'cancelled
End Select
Application.ScreenUpdating = True
End Sub
Private Sub CommandButtonReset_Click()
Call ClearControls
End Sub
Private Sub CommandButtonCancel_Click()
Unload Me
If BackToForm = "Trans" Then
frmTransaction.Show False
ElseIf BackToForm = "Member" Then
frmAddMember.Show False
Else
frmStart.Show False
End If
End Sub
Private Sub TextBoxMemSerialNo_Change()
'On Error GoTo 0
If Me.TextBoxMemSerialNo.Value = "SerialNo" Then
With Me
.CommandButtonModify.Enabled = False 'prevent accidental use
.CommandButtonDelete.Enabled = False 'prevent accidental use
.CommandButtonAddMember.Enabled = True 'restore use
End With
End If
End Sub
Private Sub cmbFind_Click()
'On Error GoTo 0
'from ComboBoxFullName & Record ID
'after choosing a member from the drop down list
'this code will populate the textboxes
'
Dim strFind As String 'what to find
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Sheets("Members").Activate 'Sheet1.Activate
Set rSearch = Sheet1.Range("b2", Range("AY65536").End(xlUp))
Dim f As Integer
strFind = Me.TextBoxMemFullName.Value 'this populates the textboxes for the chosen name Alan Pezhishgian
Application.ScreenUpdating = False
With rSearch
Set c = .Find(strFind, LookIn:=xlValues) 'c will hold Alan Pezhishgian
If Not c Is Nothing Then 'found it
c.Select
With Me 'load entry to form
'populate TextBox-es of the form here
If c.Offset(0, -47).Value = "ToBeDeleted" Then .Label31.Visible = True
.Label31.Caption = c.Offset(0, -47).Value
If c.Offset(0, -47).Value = "ToBeDeleted" Then .Label31.BackColor = RGB(255, 0, 0)
.TextBoxMemLName.Value = c.Offset(0, -42).Value
.TextBoxMemFName.Value = c.Offset(0, -44).Value
.TextBoxMemStreet.Value = c.Offset(0, -41).Value
.TextBoxMemCity.Value = c.Offset(0, -39).Value
.TextBoxMemState.Value = c.Offset(0, -38).Value
.TextBoxMemZip.Value = c.Offset(0, -37).Value
.TextBoxMemTelHome.Value = c.Offset(0, -36).Value
.TextBoxMemTelWork.Value = c.Offset(0, -35).Value
.TextBoxMemTelCell.Value = c.Offset(0, -34).Value
.TextBoxMemEmail.Value = c.Offset(0, -32).Value
'
pRecID = c.Offset(0, -45) 'RecID
pFname = c.Offset(0, -44) 'First Name
pLname = c.Offset(0, -42) 'Last Name
'
'These two lines worked to pull the information off the website.teamname
If Len(c.Offset(0, -7).Value) > 0 And c.Offset(0, -7).Value <> "Board" Then
'4/22/2013
pTeamName = c.Offset(0, 2).Value
pTeamCoach = c.Offset(0, 3).Value
Else
pTeamName = ""
pTeamCoach = ""
End If
'
'
'
.CommandButtonModify.Enabled = True 'allow amendment or
.CommandButtonDelete.Enabled = True 'allow record deletion
.CommandButtonNext.Enabled = False 'disable the button True
.CommandButtonPrevious.Enabled = False 'disable the button True
.CommandButtonReset.Enabled = True
.CommandButtonAddMember.Enabled = False 'don't want to duplicate record
If c.Offset(0, -47).Value = "" Then .Label31.Visible = False
f = 0
End With
FirstAddress = c.Address 'this is the CELL address where member's name is found
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 + vbDefaultButton2)
Case vbOK
FindAll
Me.Height = frmMax
Case vbCancel
'do nothing
End Select
End If
Else: MsgBox strFind & " not listed" 'search failed
End If
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("C2").AutoFilter
Application.ScreenUpdating = True
End Sub
Sub FindAll()
'On Error GoTo 0
Dim strFind As String 'what to find
Dim rFilter As Range 'range to search
Set rFilter = Sheet1.Range("a2", Range("AY65536").End(xlUp))
Set rng = Sheet1.Range("B1", Range("B65536").End(xlUp))
strFind = Me.TextBoxMemFullName.Value
Application.ScreenUpdating = False
With Sheet1
If Not .AutoFilterMode Then .Range("B2").AutoFilter 'check if this should be column C
rFilter.AutoFilter Field:=2, 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, 0) = c.Offset(0, -1).Value 'Record ID
.List(.ListCount - 1, 1) = c.Offset(0, 0).Value 'Full Name
.List(.ListCount - 1, 2) = c.Offset(0, 1).Value 'Last Name
.List(.ListCount - 1, 3) = c.Offset(0, 2).Value 'First Name
.List(.ListCount - 1, 4) = c.Offset(0, 3).Value 'Address
.List(.ListCount - 1, 5) = c.Offset(0, 4).Value 'City
.List(.ListCount - 1, 6) = c.Offset(0, 5).Value 'State
.List(.ListCount - 1, 7) = c.Offset(0, 6).Value 'Zip
.List(.ListCount - 1, 8) = c.Offset(0, 7).Value 'Home
.List(.ListCount - 1, 9) = c.Offset(0, 8).Value 'Work
.List(.ListCount - 1, 10) = c.Offset(0, 9).Value 'Cell
.List(.ListCount - 1, 11) = c.Offset(0, 10).Value 'DOB
End With
Next c
End With
Sheets("Members").AutoFilterMode = False
Application.ScreenUpdating = False
End Sub
Private Sub ComboBoxMemFullName_Change()
'On Error GoTo 0
If Flag Then Exit Sub
'1/13/13
If modFlag Then GoTo Skip
Me.TextBoxToBeDel.Value = ""
Me.TextBoxMemLName.Value = ""
Me.TextBoxMemFName.Value = ""
Me.TextBoxMemStreet.Value = ""
Me.TextBoxMemCity.Value = ""
Me.TextBoxMemState.Value = ""
Me.TextBoxMemZip.Value = ""
Me.TextBoxMemTelHome.Value = ""
Me.TextBoxMemTelWork.Value = ""
Me.TextBoxMemTelCell.Value = ""
Me.TextBoxMemEmail.Value = ""
'why next line bombed out
Skip:
Me.TextBoxMemFullName.Value = Sheets("LkupLists").Range("G" & ComboBoxMemFullName.ListIndex + 2).Offset(0, 0).Value
Me.TextBoxMemSerialNo.Value = Sheets("LkupLists").Range("G" & ComboBoxMemFullName.ListIndex + 2).Offset(0, -1).Value
Flag = False
End Sub
Private Sub ComboBoxMemFullName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If ComboBoxMemFullName.ListIndex = -1 Then Exit Sub
' If ComboBoxMemFullName.ListIndex = 0 Then UserForm3.Show
Call cmbFind_Click
End Sub
Private Sub ComboBoxMemSerialNo_Change()
'this procedure runs when you click on a name in the drop down box "Record ID"
If Flag Then Exit Sub
Me.TextBoxMemFullName.Value = Sheets("LkupLists").Range("A" & ComboBoxMemSerialNo.ListIndex + 2).Offset(0, 1).Value
Me.TextBoxMemSerialNo.Value = Sheets("LkupLists").Range("A" & ComboBoxMemSerialNo.ListIndex + 2).Offset(0, 0).Value
Call cmbFind_Click
End Sub
Private Sub ComboBoxMemLName_Change()
If Flag Then Exit Sub
'1/13/13
If modFlag Then GoTo Skip
Me.TextBoxMemFullName.Value = ""
Me.TextBoxMemSerialNo.Value = ""
Me.TextBoxMemFName.Value = ""
Me.TextBoxMemStreet.Value = ""
Me.TextBoxMemCity.Value = ""
Me.TextBoxMemState.Value = ""
Me.TextBoxMemZip.Value = ""
Me.TextBoxMemTelHome.Value = ""
Me.TextBoxMemTelWork.Value = ""
Me.TextBoxMemTelCell.Value = ""
Me.TextBoxMemEmail.Value = ""
'this will populate the text box Last Name with the combobox data
'but is preventing from using unique values in the combobox
Skip:
Me.TextBoxMemLName.Value = Sheets("LkupLists").Range("M" & ComboBoxMemLName.ListIndex + 2).Value
Flag = False
End Sub
Private Sub ComboBoxMemLName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Call Find_FamilyName
End Sub
Private Sub Find_FamilyName()
'from ComboBoxFamilyName
'after choosing a member from the drop down list
'this code will populate the textboxes
'
'On Error GoTo 0
Dim strFind As String 'what to find
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Sheets("Members").Activate 'Sheet1.Activate
Set rSearch = Sheet1.Range("F2", Range("AY65536").End(xlUp))
Dim f As Integer
Application.ScreenUpdating = False
'imgFolder = ThisWorkbook.Path & Application.PathSeparator & "images" & Application.PathSeparator
' strFind = Me.TextBoxMemLName.Value 'what to look for
strFind = Sheets("LkupLists").Range("M" & ComboBoxMemLName.ListIndex + 2).Value
With rSearch
Set c = .Find(strFind, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
Flag = True
c.Select
With Me 'load found data to userform
'If c.Offset(0, -5).Value = "ToBeDeleted" Then .Label31.Visible = True
'.Label31.Caption = c.Offset(0, -5).Value
'If c.Offset(0, -5).Value = "ToBeDeleted" Then .Label31.BackColor = RGB(255, 0, 0)
'chose not to use above cause cannot control it after first family member
'List box allows only 10 fields so I can not use the "tobedeleted" as a field
'to check against
'
.TextBoxMemSerialNo.Value = c.Offset(0, -3).Value
.TextBoxMemFullName.Value = c.Offset(0, 42).Value
.TextBoxMemLName.Value = c.Offset(0, 0).Value
.TextBoxMemFName.Value = c.Offset(0, -2).Value
.TextBoxMemStreet.Value = c.Offset(0, 1).Value
.TextBoxMemCity.Value = c.Offset(0, 3).Value
.TextBoxMemState.Value = c.Offset(0, 4).Value
.TextBoxMemZip.Value = c.Offset(0, 5).Value
.TextBoxMemTelHome.Value = c.Offset(0, 6).Value
.TextBoxMemTelWork.Value = c.Offset(0, 7).Value
.TextBoxMemTelCell.Value = c.Offset(0, 8).Value
.TextBoxMemEmail.Value = c.Offset(0, 10).Value
If c.Offset(0, -5).Value = "" Then .Label31.Visible = False
.CommandButtonModify.Enabled = False 'allow amendment or
.CommandButtonDelete.Enabled = False 'allow record deletion
.CommandButtonAddMember.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
FindAllFields 'Populate ListBox2 with ALL fields NOT VISIBLE
FindAll_FamilyName
Me.Height = frmMax
'this above line paints the ListBox
End If
Else: MsgBox strFind & " not listed" 'if search fails
End If
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("C2").AutoFilter 'sort by SerialNo Large to Small
'
'enter code here to select the last cell in column B
'
'Range("a1").Select
Flag = False
Application.ScreenUpdating = False
End Sub
Sub FindAll_FamilyName()
'Called by Find_FamilyName()
'Diaply the ListBox1 data onto the screen
'
'On Error GoTo 0
Dim strFind As String 'what to find
Dim rFilter As Range 'range to search
'
Set rFilter = Sheet1.Range("a2", Range("AY65536").End(xlUp))
Set rng = Sheet1.Range("F1", Range("F65536").End(xlUp))
strFind = Me.TextBoxMemLName.Value
With Sheet1
If Not .AutoFilterMode Then .Range("C2").AutoFilter
rFilter.AutoFilter Field:=6, Criteria1:=strFind 'filters by Last Name (6) chosen from list
'reorder the sheet on First Name column "D"
ActiveSheet.Range("A1:AY" & LR).Select
.Range("A2:AY" & LR).Sort key1:=Range("D2"), order1:=xlAscending, Header:=xlGuess, _
ordercustom:=1, MatchCase:=False, Orientation:=xlSortColumns
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
Me.ListBox1.Clear
Me.Width = 630
Application.ScreenUpdating = False
For Each c In rng
With Me.ListBox1
'this block writes the headers for the ListBox
'and the data
.AddItem c.Value
.List(.ListCount - 1, 0) = c.Offset(0, -3).Value 'SerialNo
.List(.ListCount - 1, 1) = c.Offset(0, 42).Value 'Full Name
.List(.ListCount - 1, 2) = c.Offset(0, 1).Value 'Address
.List(.ListCount - 1, 3) = c.Offset(0, 3).Value 'City
'.List(.ListCount - 1, 4) = c.Offset(0, 4).Value 'State
'.List(.ListCount - 1, 5) = c.Offset(0, 5).Value 'Zip
.List(.ListCount - 1, 4) = c.Offset(0, 6).Value 'Home
.List(.ListCount - 1, 5) = c.Offset(0, 7).Value 'Work
.List(.ListCount - 1, 6) = c.Offset(0, 8).Value 'Cell
.List(.ListCount - 1, 7) = c.Offset(0, 14).Value 'DOB
.List(.ListCount - 1, 8) = c.Offset(0, 21).Value 'Guardian First Name
.List(.ListCount - 1, 9) = c.Offset(0, 10).Value 'eMail
End With
Next c
End With
Application.ScreenUpdating = True
Set rng = Nothing
End Sub
Private Sub ListBox1_Click()
'When a user has been selected in the ListBox1
'this routine populates the text boxes on the form
'
'On Error GoTo 0
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
.TextBoxMemSerialNo.Value = ListBox1.List(r, 0) 'RecID
.TextBoxMemFullName.Value = ListBox1.List(r, 1) 'Full Name
.TextBoxMemLName.Value = Mid(ListBox1.List(r, 1), InStr(ListBox1.List(r, 1), " ") + 1, Len(ListBox1.List(r, 1)) - InStr(ListBox1.List(r, 1), " "))
.TextBoxMemFName.Value = Left(ListBox1.List(r, 1), InStr(ListBox1.List(r, 1), " ") - 1)
.TextBoxMemStreet.Value = ListBox1.List(r, 2) 'street
.TextBoxMemCity.Value = ListBox1.List(r, 3) 'city
.TextBoxMemState.Value = ListBox2.List(r - 1, 9) 'state
.TextBoxMemZip.Value = ListBox2.List(r - 1, 10) 'zip
.TextBoxMemTelHome.Value = ListBox1.List(r, 4) 'home
.TextBoxMemTelWork.Value = ListBox1.List(r, 5) 'work
.TextBoxMemTelCell.Value = ListBox1.List(r, 6) 'cell
.TextBoxMemEmail.Value = ListBox1.List(r, 9) 'eMail
'ListBox1.List(r, 10) 'DOB DO Not display in textbox
.Label31.Visible = False
.CommandButtonModify.Enabled = False 'allow amendment or
.CommandButtonDelete.Enabled = False 'allow record deletion
.CommandButtonAddMember.Enabled = False 'don't want duplicate
End With
'
'pass these to frmTransaction
'
pRecID = ListBox2.List(r - 1, 2) 'SerialNo
pFname = ListBox2.List(r - 1, 3) 'First Name
pLname = ListBox2.List(r - 1, 5) 'Last Name
pTeamName = ListBox2.List(r - 1, 49) 'Team No
pTeamCoach = ListBox2.List(r - 1, 50) 'Team Coach
'
End If
End Sub
Sub ClearControls()
Flag = True
With Me
For Each oCtrl In .Controls
Select Case TypeName(oCtrl)
Case "TextBox": oCtrl.Value = Empty
Case "Combobox": oCtrl.Value = Empty
End Select
Next oCtrl
.CommandButtonModify.Enabled = False 'prevent accidental use
.CommandButtonDelete.Enabled = False 'prevent accidental use 1/5/13
.CommandButtonNext.Enabled = False 'prevent accidental use
.CommandButtonPrevious.Enabled = False 'prevent accidental use
.CommandButtonReset.Enabled = False 'prevent accidental use
.CommandButtonAddMember.Enabled = True 'restore use
.ComboBoxMemFullName.ListIndex = -1
.ComboBoxMemSerialNo.ListIndex = -1
.ComboBoxMemLName.ListIndex = -1
' .Caption = "Database Example" 'userform caption
.Height = frmHt
.Width = frmWidth
End With
Flag = False
End Sub
Public Sub TxtBxMemSerialNo()
'On Error GoTo 0
Dim strFind As String
Dim rSearch As Range 'range to search
Set rSearch = MyData.Columns(1)
strFind = Me.TextBoxMemSerialNo.Value 'what to look for
Dim f As Integer
With rSearch
Set c = Cells.Find(Val(strFind), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then 'found it
With Me 'load data to form
.TextBoxMemFullName.Value = c.Offset(0, 0).Value
.TextBoxMemFullName.Value = c.Offset(0, 45).Value
.TextBoxMemLName.Value = c.Offset(0, 3).Value
.TextBoxMemFName.Value = c.Offset(0, 1).Value
.TextBoxMemStreet.Value = c.Offset(0, 4).Value
.TextBoxMemCity.Value = c.Offset(0, 6).Value
.TextBoxMemState.Value = c.Offset(0, 7).Value
.TextBoxMemZip.Value = c.Offset(0, 8).Value
.TextBoxMemTelHome.Text = c.Offset(0, 9).Text
.TextBoxMemTelWork.Text = c.Offset(0, 10).Text
.TextBoxMemTelCell.Text = c.Offset(0, 11).Text
.TextBoxMemEmail.Value = c.Offset(0, 13).Value
.CommandButtonModify.Enabled = True 'allow changes
f = 0
End With
End If
End With
End Sub
Sub CellActive()
MsgBox "Sheet: " & ActiveSheet.Name & vbNewLine & "Address :" & ActiveCell.Address, vbOKCancel
End Sub
Public Sub FindAddress()
'On Error GoTo 0
Dim strFind As String
Dim rSearch As Range 'range to search
'CellActive call to check what is the active cell address
If Not TextBoxMemFullName = "" Then
Set rSearch = MyData.Columns(48)
strFind = Me.TextBoxMemSerialNo.Value 'what to look for
Dim f As Integer
With rSearch
Set c = Range("C:C").Cells.Find(strFind, LookIn:=xlValues, lookat:=xlWhole)
'MsgBox "Sheet: " & ActiveSheet.Name & vbNewLine & "Address :" & ActiveCell.Address
If Not c Is Nothing Then 'if found
NextAddress = c.Offset(1, 0).Address
End If
f = 0
End With
Else: MsgBox strFind & " not listed" 'if search fails
End If
End Sub
Sub SortRecords()
'
' Macro4 Macro
'
'
With Sheets("LkupLists")
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A1:D" & LR).Select
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Add Key:=Range( _
"A2:A" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("LkupLists").Sort
.SetRange Range("A1:D" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("F1").Select
Range(Selection, Selection.End(xlDown)).Select
Range("F1:I" & LR).Select
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Add Key:=Range( _
"G2:G" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("LkupLists").Sort
.SetRange Range("F1:I" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("K1").Select
Range(Selection, Selection.End(xlDown)).Select
Range("K1:N" & LR).Select
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Add Key:=Range( _
"M2:M" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("LkupLists").Sort.SortFields.Add Key:=Range( _
"L2:L" & LR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("LkupLists").Sort
.SetRange Range("K1:N591")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Sub FindAllFields()
'this routine will populate ListBox2 which is not visible
Dim rng As Range
Dim strFind As String 'what to find
Dim rFilter As Range 'range to search
Dim vntData As Variant
'
Set rFilter = Sheet1.Range("A1", Range("EZ65536").End(xlUp))
Set rng = Sheet1.Range("F1", Range("F65536").End(xlUp))
strFind = Me.TextBoxMemLName.Value
With Sheet1
If Not .AutoFilterMode Then .Range("C2").AutoFilter
rFilter.AutoFilter Field:=6, Criteria1:=strFind 'filters by Last Name (6) chosen from list
'reorder the sheet on First Name column "D"
ActiveSheet.Range("A1:AY" & LR).Select
'this selects the data
.Range("A2:AY" & LR).Sort key1:=Range("D2"), order1:=xlAscending, Header:=xlGuess, _
ordercustom:=1, MatchCase:=False, Orientation:=xlSortColumns
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
Set rng = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
vntData = GetRangeData(rng, 51)
ListBox2.Clear
ListBox2.ColumnCount = 51
ListBox2.List = vntData
End With
' UserForm2.Show
End Sub
Private Function GetRangeData(Data As Range, MaxCol As Long) As Variant
Dim lngRowCount As Long
Dim rngArea As Range
Dim lngRow As Long
Dim lngCol As Long
Dim lngDataRow As Long
Dim lngDataCol As Long
Dim vntData As Variant
lngRowCount = (Data.Cells.Count / Data.Columns.Count) - 1
ReDim vntData(1 To lngRowCount, 1 To MaxCol)
lngDataRow = 1
For Each rngArea In Data.Areas
For lngRow = 1 To rngArea.Rows.Count
If rngArea.Cells(lngRow, 1).Row = 1 Then
' skip header
Else
lngDataCol = 1
For lngCol = 1 To MaxCol
vntData(lngDataRow, lngDataCol) = rngArea.Cells(lngRow, lngCol).Text
lngDataCol = lngDataCol + 1
Next
lngDataRow = lngDataRow + 1
End If
Next
Next
GetRangeData = vntData
End Function
'
'
Code:
'Transactions userform
Private Declare Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Option Explicit
Function fnWSExists(wsName As String) As Boolean
On Error Resume Next
fnWSExists = Worksheets(wsName).Name = wsName
End Function
'**************Minimize button
Sub FormatUserForm(UserFormCaption As String)
Dim hWnd As Long
Dim exLong As Long
hWnd = FindWindowA(vbNullString, UserFormCaption)
exLong = GetWindowLongA(hWnd, -16)
If (exLong And &H20000) = 0 Then
SetWindowLongA hWnd, -16, exLong Or &H20000
Else
End If
End Sub
'*******************
Private Sub CommandButtonCheckTotals_Click()
BackToForm = "Trans"
frmTransaction.Hide
frmTotals.Show False
End Sub
Private Sub CommandButtonSave_Click()
'On Error GoTo 0
Dim nextrow As Integer
nextrow = WorksheetFunction.CountA(Sheets("Transactions").Range("A:A")) + 1
Sheets("Transactions").Cells(nextrow, 1) = Format(Now, "Short Date") 'frmTransaction.textboxDate.Value
Sheets("Transactions").Cells(nextrow, 2) = frmTransaction.textBoxReceiptNo.Value
Sheets("Transactions").Cells(nextrow, 3) = frmTransaction.TextBoxCheckCCNo.Value
Sheets("Transactions").Cells(nextrow, 4) = frmTransaction.ComboBoxPayMethod.Value
Sheets("Transactions").Cells(nextrow, 5).Formula = "=IFERROR(INDEX(Members!C:C,MATCH(IF(INDIRECT(""G""&ROW())="""",INDIRECT(""F""&ROW()),INDIRECT(""F""&ROW())&"" ""&INDIRECT(""G""&ROW())),Members!AV:AV,0)),""Not Found"")"
Sheets("Transactions").Cells(nextrow, 5).Interior.Color = RGB(255, 0, 0)
Sheets("Transactions").Cells(nextrow, 6) = StrConv(Trim(frmTransaction.TextBoxFirstName.Value), vbProperCase)
Sheets("Transactions").Cells(nextrow, 7) = StrConv(Trim(frmTransaction.TextBoxLastName.Value), vbProperCase)
'
If frmTransaction.TextBoxMembershipYear = "" And frmTransaction.ComboBoxService.Value = "Dues" Then
Sheets("Transactions").Cells(nextrow, 8) = Year(Date)
Else
Sheets("Transactions").Cells(nextrow, 8) = frmTransaction.TextBoxMembershipYear.Value
End If
'
'
If frmTransaction.TextBoxTeamNo.Value = "" Or frmTransaction.ComboBoxService.Value = "Dues" Then
Sheets("Transactions").Cells(nextrow, 9).Formula = "=IFERROR(INDEX(Members!R:R,MATCH(IF(INDIRECT(""G""&ROW())="""",INDIRECT(""F""&ROW()),INDIRECT(""F""&ROW())&"" ""&INDIRECT(""G""&ROW())),Members!AV:AV,0)),"""")"
Sheets("Transactions").Cells(nextrow, 9).Interior.Color = RGB(255, 0, 0)
Else
Sheets("Transactions").Cells(nextrow, 9) = frmTransaction.TextBoxTeamNo.Value
End If
'
'
If frmTransaction.TextBoxTeamCoach.Value = "" Or frmTransaction.ComboBoxService.Value = "Dues" Then
Sheets("Transactions").Cells(nextrow, 10) = ""
Else
Sheets("Transactions").Cells(nextrow, 10) = frmTransaction.TextBoxTeamCoach.Value
End If
'
Sheets("Transactions").Cells(nextrow, 11) = frmTransaction.TextBoxNotes.Value
Sheets("Transactions").Cells(nextrow, 12) = frmTransaction.TextBoxTotalPaid.Value
Sheets("Transactions").Cells(nextrow, 13) = frmTransaction.TextBoxDepositDate.Value
Sheets("Transactions").Cells(nextrow, 14) = frmTransaction.ComboBoxService.Value
Sheets("Transactions").Cells(nextrow, 15).Formula = "= IF(INDIRECT(""M""&ROW())>0,"""",INDIRECT(""L""&ROW()))"
Sheets("Transactions").Cells(nextrow, 15).Interior.Color = RGB(255, 0, 0)
Sheets("Transactions").Cells(nextrow, 16).Formula = "=IF(COUNTIF(INDIRECT(ADDRESS(ROW(DepositDate),COLUMN(DepositDate),1)&"":""&ADDRESS(ROW(),COLUMN(DepositDate),4)),INDIRECT(ADDRESS(ROW(),COLUMN(DepositDate))))=1,INDIRECT(ADDRESS(ROW(),COLUMN(DepositDate))),"""")"
Sheets("Transactions").Cells(nextrow, 16).Interior.Color = RGB(255, 0, 0)
Sheets("Transactions").Cells(nextrow, 18).Formula = "=IF(COUNTIF(INDIRECT(ADDRESS(ROW(ReceiptNo),COLUMN(ReceiptNo),1)&"":""&ADDRESS(ROW(),COLUMN(ReceiptNo),4)),INDIRECT(ADDRESS(ROW(),COLUMN(ReceiptNo))))=1,INDIRECT(ADDRESS(ROW(),COLUMN(ReceiptNo))),"""")"
Sheets("Transactions").Cells(nextrow, 18).Interior.Color = RGB(255, 0, 0)
ClearData
'did this to keep the form active until cancelled
'Unload frmTransaction
'lookup First & Last Name to get RecID# - did not work
'Private Sub TextBoxLastName_Change()
'TextBoxRecID.Value = Application.VLookup(Me.TextBoxFirstName.Value + " " + Me.TextBoxLastName.Value, Range("members!e:e"), 2, 0)
'End Sub
End Sub
'clear the text boxes and combos after transaction is saved
Private Sub ClearData()
'frmTransaction.textBoxReceiptNo = ""
frmTransaction.TextBoxCheckCCNo = ""
frmTransaction.ComboBoxPayMethod = ""
frmTransaction.TextBoxFirstName = ""
'frmTransaction.TextBoxLastName = ""
frmTransaction.TextBoxRecID = ""
frmTransaction.TextBoxMembershipYear = ""
frmTransaction.TextBoxTeamNo = ""
frmTransaction.TextBoxTeamCoach = ""
frmTransaction.TextBoxNotes = ""
frmTransaction.TextBoxTotalPaid = ""
frmTransaction.TextBoxDepositDate = ""
frmTransaction.ComboBoxService = ""
End Sub
'populate ComboBoxService
Private Sub UserForm_Initialize()
'On Error GoTo 0
Call FormatUserForm(Me.Caption)
If BackToForm = "Main" Then
frmTransaction.CommandButtonCheckTotals.Enabled = False 'disable the button
End If
Me.ComboBoxService.List = Worksheets("LookupList").Range("ChartOfAccounts").Value
frmTransaction.TextBoxTeamNo = frmMain.pTeamName
frmTransaction.TextBoxTeamCoach = frmMain.pTeamCoach
frmTransaction.TextBoxFirstName = frmMain.pFname
frmTransaction.TextBoxLastName = frmMain.pLname
frmTransaction.TextBoxRecID = frmMain.pRecID
End Sub
'populate ComboBoxPayMethod
Private Sub UserForm_Activate()
frmTransaction.ComboBoxPayMethod.AddItem "Check"
frmTransaction.ComboBoxPayMethod.AddItem "Cash"
frmTransaction.ComboBoxPayMethod.AddItem "CC"
End Sub
Private Sub UserForm_QueryClose _
(Cancel As Integer, CloseMode As Integer)
' Prevents use of the Close button
If CloseMode = vbFormControlMenu Then
MsgBox "The Close button is disabled, please click Cancel."
Cancel = True
End If
End Sub
Private Sub CommandButtonCancel_Click()
'This is what I have to work on to make this go back to frmNewMember or frmStart or frmMain
Unload frmTransaction
If BackToForm = "Member" Then
frmAddMember.Show False
ElseIf BackToForm = "Start" Then
frmStart.Show False
ElseIf BackToForm = "Main" Then
frmMain.Show False
Else
frmStart.Show False
End If
End Sub
