Fully Automatic data entry form Part - 5
Dynamic Fully automatic Data Entry form in Excel VBA part - 5
Download link of Practice File and VBA Code file in Bottom of page
प्रैक्टिस फ़ाइल ओर VBA कोड की फ़ाइल का लिंक पेज के अंत मे दिया गया है।
Copy VBA code here
Option Explicit
Public iwidth As Integer
Public iheight As Integer
Public ileft As Integer
Public itop As Integer
Public bstate As Boolean
Sub Reset()
Dim i As Long
i = [Counta(Database!A:A)]
With frmform
.txtname.Value = ""
.txtID.Value = ""
.txtcont.Value = ""
.txtdate.Value = ""
.txtcity.Value = ""
.optmale.Value = False
.Optfemale.Value = False
'default color
.txtname.BackColor = vbWhite
.txtID.BackColor = vbWhite
.txtcont.BackColor = vbWhite
.txtdate.BackColor = vbWhite
.txtcity.BackColor = vbWhite
.cmddesg.BackColor = vbWhite
'--------------------------
.cmddesg.Clear
'.cmddesg.AddItem "Manager"
'.cmddesg.AddItem "Accountant"
'.cmddesg.AddItem "Supervisor"
'.cmddesg.AddItem "Peon"
'.cmddesg.AddItem "Cleark"
shSupport.Range("A2", shSupport.Range("A" & Application.Rows.Count).End(xlUp)).Name = "Dynamic"
.cmddesg.RowSource = "Dynamic"
.txtRowNumber.Value = ""
'here this code is related with search feature
Call Add_SearchColumn
ThisWorkbook.Sheets("Database").AutoFilterMode = False
ThisWorkbook.Sheets("SearchData").AutoFilterMode = False
ThisWorkbook.Sheets("SearchData").Cells.Clear
'************
.Lstdatabase.ColumnCount = 8
.Lstdatabase.ColumnHeads = True
.Lstdatabase.ColumnWidths = "30,68,80,75,75,55,50,55"
If i > 1 Then
.Lstdatabase.RowSource = "Database!A2:H" & i
Else
.Lstdatabase.RowSource = "Database!A2:H2"
End If
End With
End Sub
Sub submit()
Dim sh As Worksheet
Dim i As Long
Set sh = ThisWorkbook.Sheets("Database")
If frmform.txtRowNumber.Value = "" Then
i = [Counta(Database!A:A)] + 1
Else
i = frmform.txtRowNumber.Value
End If
With sh
.Cells(i, 1) = "=Row()-1"
.Cells(i, 2) = frmform.txtname.Value
.Cells(i, 3) = frmform.txtID.Value
.Cells(i, 4) = frmform.txtcont.Value
.Cells(i, 5) = frmform.txtdate.Value
.Cells(i, 6) = frmform.txtcity.Value
.Cells(i, 7) = IIf(frmform.Optfemale.Value = True, "Female", "Male")
.Cells(i, 8) = frmform.cmddesg.Value
End With
End Sub
Sub show_form()
frmform.Show
End Sub
Function selected_List() As Long
Dim E As Long
selected_List = 0
For E = 0 To frmform.Lstdatabase.ListCount - 1
If frmform.Lstdatabase.Selected(E) = True Then
selected_List = E + 1
Exit For
End If
Next E
End Function
Sub Add_SearchColumn()
frmform.EnableEvents = False
With frmform.cmdSearchColumn
.Clear
.AddItem "All"
.AddItem "Emp Name"
.AddItem "Emp ID"
.AddItem "Contact"
.AddItem "DOJ"
.AddItem "City"
.AddItem "Gender"
.AddItem "Desg"
.Value = "All"
End With
frmform.EnableEvents = True
frmform.txtSearch.Value = ""
frmform.txtSearch.Enabled = False
frmform.cmdSearch.Enabled = False
End Sub
'**********************
Sub SearchData()
Application.ScreenUpdating = False
Dim shDatabase As Worksheet 'Database sheet
Dim shSearchData As Worksheet 'search datasheet
Dim iColumn As Integer 'tohold the selected column number in data sheet
Dim iDatabaseRow As Long 'to store the last non-blank row number available in database
Dim iSearchRow As Long 'to hold the last non-blank row number available in SearchData sheet
Dim sColumn As String 'to store the column selection
Dim sValue As String 'to hold the search text value
Set shDatabase = ThisWorkbook.Sheets("Database")
Set shSearchData = ThisWorkbook.Sheets("searchData")
iDatabaseRow = ThisWorkbook.Sheets("Database").Range("A" & Application.Rows.Count).End(xlUp).Row
sColumn = frmform.cmdSearchColumn.Value
sValue = frmform.txtSearch.Value
iColumn = Application.WorksheetFunction.Match(sColumn, shDatabase.Range("A1:H1"), 0)
'Remove filter from database worksheet
If shDatabase.FilterMode = True Then
shDatabase.AutoFilterMode = False
End If
'apply filter on database worksheet
If frmform.cmdSearchColumn.Value = "Emp Name" Then
shDatabase.Range("A1:H" & iDatabaseRow).AutoFilter Field:=iColumn, Criteria1:=sValue
Else
shDatabase.Range("A1:H" & iDatabaseRow).AutoFilter Field:=iColumn, Criteria1:="*" & sValue & "*"
End If
If Application.WorksheetFunction.Subtotal(3, shDatabase.Range("B:B")) >= 2 Then
'code to remove the previous Date from search data worksheet
shSearchData.Cells.Clear
shDatabase.AutoFilter.Range.Copy shSearchData.Range("A1")
Application.CutCopyMode = False
iSearchRow = shSearchData.Range("A" & Application.Rows.Count).End(xlUp).Row
frmform.Lstdatabase.ColumnCount = 8
frmform.Lstdatabase.ColumnWidths = "30,68,80,75,75,55,50,55"
If iSearchRow > 1 Then
frmform.Lstdatabase.RowSource = "SearchData!A2:H" & iSearchRow
MsgBox "Record Found."
End If
Else
MsgBox "No Record Found."
End If
shDatabase.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Function ValidatePrintDetails() As Boolean
ValidatePrintDetails = True
Dim iEmployeeID As Variant
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Print")
iEmployeeID = frmform.txtID.Value
With frmform
'default color
.txtname.BackColor = vbWhite
.txtID.BackColor = vbWhite
.txtcont.BackColor = vbWhite
.txtdate.BackColor = vbWhite
.txtcity.BackColor = vbWhite
.cmddesg.BackColor = vbWhite
'--------------------------
If Trim(.txtID.Value) = "" Then
MsgBox "Please enter Employee ID .", vbOKOnly + vbInformation, "Emp ID"
ValidatePrintDetails = False
.txtID.BackColor = vbRed
.txtID.SetFocus
Exit Function
End If
If Trim(.txtname.Value) = "" Then
MsgBox "Please enter Employee name .", vbOKOnly + vbInformation, "Emp name"
ValidatePrintDetails = False
.txtname.BackColor = vbRed
.txtname.SetFocus
Exit Function
End If
'Validating Gender
If .Optfemale.Value = False And .optmale.Value = False Then
MsgBox "Please Select Gender .", vbOKOnly + vbInformation, "Gender"
ValidatePrintDetails = False
Exit Function
End If
If Trim(.cmddesg.Value) = "" Then
MsgBox "Please Select Desg .", vbOKOnly + vbInformation, "Desg"
ValidatePrintDetails = False
.cmddesg = vbRed
.cmddesg.SetFocus
Exit Function
End If
If Trim(.txtcity.Value) = "" Then
MsgBox "Please enter city .", vbOKOnly + vbInformation, "City"
ValidatePrintDetails = False
.txtcity.BackColor = vbRed
.txtcity.SetFocus
Exit Function
End If
If Trim(.txtcont.Value) = "" Then
MsgBox "Please Enter contact number.", vbOKOnly + vbInformation, "Contact"
ValidatePrintDetails = False
.txtcont.BackColor = vbRed
.txtcont.SetFocus
Exit Function
End If
If Trim(.txtdate.Value) = "" Then
MsgBox "Please enter Date of Joining .", vbOKOnly + vbInformation, "DATE"
ValidatePrintDetails = False
.txtdate.BackColor = vbRed
.txtdate.SetFocus
Exit Function
End If
End With
End Function
Sub Print_Form()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Print")
With frmform
sh.Range("E5").Value = .txtID.Value
sh.Range("E7").Value = .txtname.Value
sh.Range("E9").Value = IIf(.Optfemale.Value = True, "Female", "Male")
sh.Range("E11").Value = .cmddesg.Value
sh.Range("E13").Value = .txtcity.Value
sh.Range("E15").Value = .txtcont.Value
sh.Range("E17").Value = .txtdate.Value
End With
'code to print the form or export to PDF
sh.PageSetup.PrintArea = "$B$2:$F$19"
'Sh.PrintOut copies:= 1, IgnorePrintArea:= false
sh.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & Application.PathSeparator & frmform.txtname.Value & ".pdf"
MsgBox "Employee details have been printed.", vbOKOnly + vbInformation, "Print"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub Maximize_Restore()
If Not bstate = True Then
iwidth = frmform.Width
iheight = frmform.Height
itop = frmform.Top
ileft = frmform.Left
'Code for full screen
With Application
.WindowState = xlMaximized
frmform.Zoom = Int(.Width / frmform.Width * 100)
frmform.StartUpPosition = 0
frmform.Left = .Left
frmform.Top = .Top
frmform.Width = .Width
frmform.Height = .Height
End With
frmform.cmdFullScreen.Caption = "Restore"
bstate = True
Else
With Application
.WindowState = xlNormal
frmform.Zoom = 100
frmform.StartUpPosition = 0
frmform.Left = ileft
frmform.Width = iwidth
frmform.Height = iheight
frmform.Top = itop
End With
frmform.cmdFullScreen.Caption = "Full Screen"
bstate = False
End If
End Sub
*********************************************************
Option Explicit
Public EnableEvents As Boolean
Private Sub ccmdFullScreen_Click()
Call Maximize_Restore
End Sub
Private Sub cmdcancel_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to reset it?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
Call Reset
End Sub
Private Sub cmdDelete_Click()
Dim iRow As Long
If selected_List = 0 Then
MsgBox "No row is selected.", vbOKOnly + vbInformation, "Delete"
Exit Sub
End If
Dim i As VbMsgBoxResult
i = MsgBox("Do you want to delete the selected record?", vbYesNo + vbQuestion, "Confirmation")
If i = vbNo Then Exit Sub
iRow = Application.WorksheetFunction.Match(Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 0), ThisWorkbook.Sheets("Database").Range("A:A"), 0)
ThisWorkbook.Sheets("Database").Rows(iRow).Delete
Call Reset
MsgBox "Selected record has been deleted.", vbOKOnly + vbInformation, "Deleted"
End Sub
Private Sub cmddesg_Change()
Me.txtID.Value = "Reg-" & Left(Me.cmddesg, 2) & Me.txtdate.Value
End Sub
Private Sub cmdEdit_Click()
If selected_List = 0 Then
MsgBox "No Row is selected.", vbOKOnly + vbInformation, "Edit"
Exit Sub
End If
'this code to update the value to respective contors
Dim gender As String
Me.txtRowNumber.Value = Application.WorksheetFunction.Match(Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 0), ThisWorkbook.Sheets("Database").Range("A:A"), 0)
Me.txtname.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 1)
Me.txtID.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 2)
Me.txtcont.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 3)
Me.txtdate.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 4)
Me.txtcity.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 5)
gender = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 6)
If gender = "Female" Then
Me.Optfemale.Value = True
Else
Me.optmale.Value = True
End If
Me.cmddesg.Value = Me.Lstdatabase.List(Me.Lstdatabase.ListIndex, 7)
MsgBox "Please make th erequired changes and click on 'save' button to update.", vbOKOnly + vbInformation, "Edit"
End Sub
Private Sub cmdFullScreen_Click()
Call Maximize_Restore
End Sub
Private Sub cmdPrint_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to Print ?", vbYesNo + vbInformation, "Print")
If msgValue = vbNo Then Exit Sub
If ValidatePrintDetails() = True Then
Call Print_Form
End If
End Sub
Private Sub cmdsave_Click()
Dim msgValue As VbMsgBoxResult
msgValue = MsgBox("Do you want to save it?", vbYesNo + vbInformation, "Confirmation")
If msgValue = vbNo Then Exit Sub
If ValidatePrintDetails() = True Then
Call submit
Call Reset
End If
End Sub
Private Sub cmdSearch_Click()
If Me.txtSearch.Value = "" Then
MsgBox "Please enter the search value.", vbOKOnly + vbInformation, "Search"
Exit Sub
End If
Call SearchData
End Sub
Private Sub cmdSearchColumn_Change()
If Me.EnableEvents = False Then Exit Sub
If Me.cmdSearchColumn.Value = "All" Then
Call Reset
Else
Me.txtSearch.Value = ""
Me.txtSearch.Enabled = True
Me.cmdSearch.Enabled = True
End If
End Sub
Private Sub txtdate_Change()
Me.txtID.Value = "Reg-" & Left(Me.cmddesg, 2) & Me.txtdate.Value
End Sub
Private Sub UserForm_Initialize()
Call Reset
End Sub
VBA Code File Download:- Click here
Practice File Download:- Click here
Post a Comment