I'm new to VBA and have attempted to create a userform (from youtube videos) that will allow my team to add and update projects in a database. The userform contains a search function that can search by column header "cboHeader". The search criteria entered by the user should update cells P1 and P2 which control the filter, however some columns don't seem to copy over.
Code:
Private Sub cmdAdd_Click()
'dimention the variable
Dim DataSH As Worksheet
Dim Addme As Range
'set the variable
Set DataSH = Sheet1
'error handler
On Error GoTo errHandler:
'set variable for the destination
Set Addme = DataSH.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
If Me.txtDate = "" Or Me.txtProject = "" Or Me.cboCategory = "" Then
MsgBox "There is insufficient data, Please return and add the needed information"
Exit Sub
End If
'send the values to the database
With DataSH
'add the unique reference ID then all other values
Addme.Offset(0, -1) = DataSH.Range("O1").value + 1
Addme.value = Me.txtDate
Addme.Offset(0, 1).value = Me.cboCategory
Addme.Offset(0, 2).value = Me.txtProject
Addme.Offset(0, 3).value = Me.txtHPG
Addme.Offset(0, 4).value = Format(Me.txtSubmitted, "#,###")
Addme.Offset(0, 5).value = Format(Me.cboEffective, "mm/dd/yyyy")
Addme.Offset(0, 6).value = Me.cboSourcing
Addme.Offset(0, 7).value = Me.cboLDR
End With
'sort the data by "Date Submitted"
DataSH.Select
With DataSH
.Range("A2:N100000").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
End With
'clear the values after entry
Clear
'communicate with the user
MsgBox "Your employee data was successfully added"
'return to interface sheet sheet
Sheet2.Select
'reset the form
On Error GoTo 0
Exit Sub
errHandler:
'if error occurs then show me exactly where the error occurs
MsgBox "Error " & Err.Number & _
" (" & Err.Description & ")in procedure cmdClear_Click of Form ValidationDB"
End Sub
Sub Clear()
Dim ctl As Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ListBox"
ctl.RowSource = ""
Case "ComboBox"
ctl.value = ""
End Select
Next ctl
End Sub
Private Sub cmdClear_Click()
'clear all controls
Clear
End Sub
Private Sub cmdClear2_Click()
'clear all controls
Clear
End Sub
Private Sub cmdSearch_Click()
End Sub
Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub
Private Sub cmdContact_Click()
'dim the variables
Dim Crit As Range
Dim FindMe As Range
Dim DataSH As Worksheet
'error handler
On Error GoTo errHandler:
'set object variables
Set DataSH = Sheet1
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'///////////////////////////////////////////
'if header is selected add the criteria
If Me.cboHeader.value <> "All_Columns" Then
If Me.txtSearch = "" Then
DataSH.Range("P2") = ""
Else
DataSH.Range("P2") = "*" & Me.txtSearch.value & "*"
End If
End If
'//////////////////////////////////////////
'if all columns is selected
If Me.cboHeader.value = "All_Columns" Then
'find the value in the column
Set FindMe = DataSH.Range("A2:N30000").Find(What:=txtSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'variable for criteria header
Set Crit = DataSH.Cells(1, FindMe.Column)
'if no criteria is added to the search
If Me.txtSearch = "" Then
DataSH.Range("P2") = ""
DataSH.Range("P1") = ""
Else
'add values from the search
DataSH.Range("P1") = Crit
If Crit = "ID" Then
DataSH.Range("P2") = Me.txtSearch.value
Else
DataSH.Range("P2") = "*" & Me.txtSearch.value & "*"
End If
'show in the userform the header that is added
Me.txtAllColumn = DataSH.Range("P1").value
End If
End If
'/////////////////////////////////////////
'filter the data
DataSH.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$P$1:$P$2"), CopyToRange:=Range("Data!$R$1:$AE$1"), _
Unique:=False
'add the dynamic data to the listbox
lstEmployee.RowSource = DataSH.Range("outdata").Address(external:=True)
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'if error occurs then show me exactly where the error occurs
MsgBox "No match found for " & txtSearch.Text
'clear the listbox if no match is found
Me.lstEmployee.RowSource = ""
Exit Sub
End Sub
Private Sub cmdEdit_Click()
'declare the variables
Dim findvalue As Range
Dim cNum As Integer
Dim DataSH As Worksheet
'error handling
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
Set DataSH = Sheet1
'check for values
If emp1.value = "" Or emp2.value = "" Then
MsgBox "There is not data to edit"
Exit Sub
End If
'clear the listbox
lstEmployee.RowSource = ""
'find the row to edit
Set findvalue = DataSH.Range("A:A"). _
Find(What:=Me.emp1.value, LookIn:=xlValues, LookAt:=xlWhole)
'update the values
findvalue = emp1.value
findvalue.Offset(0, 1) = emp2.value
findvalue.Offset(0, 2) = emp3.value
findvalue.Offset(0, 3) = emp4.value
findvalue.Offset(0, 4) = emp5.value
findvalue.Offset(0, 5) = emp6.value
findvalue.Offset(0, 6) = emp7.value
findvalue.Offset(0, 7) = emp8.value
findvalue.Offset(0, 8) = emp9.value
findvalue.Offset(0, 9) = emp10.value
findvalue.Offset(0, 10) = emp11.value
findvalue.Offset(0, 11) = emp12.value
findvalue.Offset(0, 12) = emp13.value
'filter the data
DataSH.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$P$1:$P$2"), CopyToRange:=Range("Data!$R$1:$AE$1"), _
Unique:=False
'if no data exists then clear the rowsource
If DataSH.Range("R2").value = "" Then
lstEmployee.RowSource = ""
Else
'add the filtered data to the rowsource
lstEmployee.RowSource = DataSH.Range("outdata").Address(external:=True)
End If
'return to sheet
Sheet2.Select
'Protect all sheets
'Protect_All
'error block
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
'Protect_All
'show error information in a messagebox
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please notify the administrator"
End Sub
Private Sub DTPicker1_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)
End Sub
Private Sub emp11_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)
End Sub
Private Sub emp2_Change()
End Sub
Private Sub emp7_Change()
End Sub
Private Sub lstEmployee_Click()
'dim the variables
Dim i As Integer
On Error Resume Next
'find the selected list item
i = Me.lstEmployee.ListIndex
'add the values to the text boxes
Me.emp1.value = Me.lstEmployee.Column(0, i)
Me.emp2.value = Format(Me.lstEmployee.Column(1, i), "mm/dd/yyyy")
Me.emp3.value = Me.lstEmployee.Column(2, i)
Me.emp4.value = Me.lstEmployee.Column(3, i)
Me.emp5.value = Me.lstEmployee.Column(4, i)
Me.emp6.value = Format(Me.lstEmployee.Column(5, i), "#,###")
Me.emp7.value = Format(Me.lstEmployee.Column(6, i), "mm/dd/yyyy")
Me.emp8.value = Me.lstEmployee.Column(7, i)
Me.emp9.value = Me.lstEmployee.Column(8, i)
Me.emp10.value = Me.lstEmployee.Column(9, i)
Me.emp11.value = Format(Me.lstEmployee.Column(10, i), "#,###")
Me.emp12.value = Format(Me.lstEmployee.Column(11, i), "#,###")
Me.emp13.value = Format(Me.lstEmployee.Column(12, i), "mm/dd/yyyy")
Me.emp14.value = Me.lstEmployee.Column(13, i)
On Error GoTo 0
End Sub
