Abdul Alim: a little bit learning, let's go

Excel, VBA and Power BI tutorials 

• Workbook open but application hide

Application.Visible = False

• Open url or any web address

Dim url As String

url = "https://sites.google.com/view/abdulalim34/home"

ActiveWorkbook.FollowHyperlink url

• Select series of textbox or Combobox or any object

Dim m As Integer

For m = 1 To 5

If Me("TextBox" & m) = "" Then

MsgBox "All Fields are mandatory", vbInformation, "Blank!!!"

Exit Sub

End If

Next m

• Textbox or ComboBox value clear

Me.TextBox1.Value = ""

Me.TextBox2.Value = ""

Me.TextBox3.Value = ""

Me.TextBox4.Value = ""

Me.TextBox5.Value = ""

• Workbook close & Application quit

Dim App As Excel.Application

Unload Me

ThisWorkbook.Close savechanges:=False

App.Quit

Set App = Nothing

• Message box show for any command

If Me.TextBox9.Value <> Me.TextBox10.Value Then

MsgBox "Password does not match", vbOKOnly, "Re-Type the Password"

End If

Dim m As Integer

For m = 7 To 11

If Me("TextBox" & m) = "" Then

MsgBox "All Fields are mandatory", vbInformation, "Blank!!!"

Exit Sub

End If

Next m

• Userform open

Userform.show

• Userform close

Unload Userform

• Userform hide

Userform.hide

• Display worksheet value in textbox of userform

TextBox6.Value = ThisWorkbook.Sheets("sheet1").Range("B1").Value

• Collect Textbox or combobox value from worksheet

Dim csh As Worksheet

Set csh = ThisWorkbook.Sheets("Manpower_All")

Dim i As Long

For i = 2 To csh.Range("A1000").End(xlUp).row

For i = 2 To csh.Range("A" & Application.Rows.Count).End(xlUp).row

If csh.Range("A" & i).Value = Me.ComboBox11.Value Then

Me.TextBox7.Value = csh.Range("D" & i).Value & ", " & csh.Range("X" & i).Value

Me.TextBox13.Value = csh.Range("Q" & i).Value

Me.TextBox37.Value = csh.Range("D" & i).Value & ", " & csh.Range("Q" & i).Value

End If

Next i

• Textbox value show date (Today)

Me.TextBox12.Value = VBA.Now

• Textbox value date format change

If IsDate(Me.TextBox12.Text) Then

Me.TextBox12.Text = Format(Me.TextBox12.Text, "dd-Mmm-yy")

End If

• Textbox set focus

If Me.TextBox2.Value = "" Then

        MsgBox "Please enter Name of product", vbCritical, "Blank!!!"

       TextBox2.SetFocus

       Exit Sub

    End If

• Connect to MS Acces database & save data

Dim cnn As New ADODB.Connection

    Dim rst As New ADODB.Recordset

    Dim qry As String

    On Error Resume Next

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ("\\172.23.89.105\Anomalies Identification & Action taken$") & "\DatabaseQA.accdb"

    or

   cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

    If Me.txtId.Value <> "" Then

        qry = "SELECT * FROM TBL_Sample WHERE ID = " & Me.txtId.Value

    Else

        qry = "SELECT * FROM TBL_Sample Where ID = 0"

    End If

    rst.Open qry, cnn, adOpenKeyset, adLockOptimistic

    If rst.RecordCount = 0 Then

        rst.AddNew

    End If

    rst.Fields("Name_Of_Product").Value = Me.TextBox2.Value

    rst.Fields("Batch").Value = Me.TextBox3.Value

    rst.Fields("Related_Area").Value = Me.TextBox4.Value

    rst.Fields("Date").Value = VBA.Now

    rst.Fields("Time").Value = VBA.Now

    rst.Fields("User").Value = Me.TextBox1.Value

    rst.Fields("Application_User").Value = Application.UserName

    rst.Update

    Me.txtId.Value = ""

    Me.TextBox2.Value = ""

    Me.TextBox3.Value = ""

    Me.TextBox4.Value = ""

MsgBox "Saved Succesfully", vbInformation, ""

  TextBox2.SetFocus

Call List_box_Data

• Used range copy from Worksheet

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

sh.UsedRange.Copy

• Used range copy and Paste from Worksheet to Worksheet

Dim sh As Worksheet

Dim ssh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

Set ssh = ThisWorkbook.Sheets("Support2")

sh.UsedRange.Copy

ssh.Range("A2"). PasteSpecial xlPasteValues

• Specific range copy and paste from Worksheet to Worksheet

Dim sh As Worksheet

Dim ssh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

Set ssh = ThisWorkbook.Sheets("Support2")

sh.Range("A2").Copy

sh.Range("A2"). PasteSpecial xlPasteValues

sh.Range("O2:O").Copy

ssh.Range("C2").PasteSpecial xlPasteValues

• Specific used range copy and paste from Worksheet to Worksheet

Dim sh As Worksheet

Dim ssh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

Set ssh = ThisWorkbook.Sheets("Support2")

Dim lr As Long

    lr = Application.WorksheetFunction.CountA(sh.Range("A:A"))

    ActiveWindow.DisplayGridlines = False

sh.Range("O2:O" & lr).Copy

ssh.Range("C2").PasteSpecial xlPasteValues

• Specific range entire row Clear contents only

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

sh.Range("A2:A" & Application.Rows.Count).EntireRow.ClearContents

• Specific range entire row Clear all contents & formats

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

sh.Range("A2:A" & Application.Rows.Count).EntireRow.Clear

• Clear all contents & formats from woksheet

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

sh.cells.clear

• Textbox show default value

Me.ComboBox2.Value = "ALL"

Me.ComboBox10.Value = "Date"

• When value not found that does not error

On Error Resume Next

• Specific column used range formatting

Dim ssh As Worksheet

Set ssh = ThisWorkbook.Sheets("Support")

Dim i As Long

  For i = 2 To Application.WorksheetFunction.CountA(ssh.Range("C:C"))

If i > 1 Then

ssh.Range("B" & i).Value = i - 1

ssh.UsedRange.Borders.LineStyle = xlHairline

ssh.UsedRange.WrapText = True

ssh.UsedRange.VerticalAlignment = xlCenter

ssh.UsedRange.HorizontalAlignment = xlLeft

End If

• Specific range formatting

Application.ScreenUpdating = False

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Training Summary")

With sh.Range("B7:U8")

    .Borders.LineStyle = xlHairline

    .Font.Name = "Arial"

    .Font.Size = 11

    '.WrapText = True

End With

    sh.Range("B7:C7,P7:R7,B8:D8,L8:N8").Font.Bold = True

With sh.Range("B10:U10")

    .Borders.LineStyle = xlHairline

    .Font.Name = "Arial"

    .Font.Size = 11

    .Font.Bold = True

    .HorizontalAlignment = xlCenter

    .VerticalAlignment = xlCenter

    '.WrapText = True

End With

If Range("B11") <> "" Then Range("B11:U11").Borders.LineStyle = xlHairline

• Print another file and close after print

On Error Resume Next

Application.ScreenUpdating = False

    Dim wBook As Excel.Workbook

    Dim sh As Worksheet

    Dim ssh As Worksheet

    Dim atsh As Worksheet

    Dim FileName As String

    FileName = "C:\Program Files\Anomalies Identification & Action taken\Print.xlsb"

    Set wBook = Workbooks.Open(FileName)

    Set atsh = wBook.Sheets("Print_Record")

    Userform.Hide

    Application.Visible = True

    atsh.PrintPreview

    wBook.Close savechanges:=False

    Application.Visible = False

    Userform.Show

• Userform hide and application visible

Userform.Hide

Application.Visible = True

• Delete data from listbox

If Me.ListBox1.ListIndex = -1 Then

    MsgBox "Please select record(s) to delete", vbCritical, ""

    Exit Sub

End If

Dim confirmation As Integer

confirmation = MsgBox("Do you want to delete selected record(s)?", vbQuestion + vbYesNo, "Confirmation")

If confirmation = vbNo Then Exit Sub

Dim i As Long

   Dim cnn As New ADODB.Connection

    Dim rst As New ADODB.Recordset

    Dim qry As String

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ("\\172.23.89.105\Anomalies Identification & Action taken$") & "\DatabaseQA.accdb"

or

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

For i = 0 To Me.ListBox1.ListCount - 1

     If Me.ListBox1.Selected(i) = True Then

        qry = "Delete FROM TBL_Sample WHERE ID = " & Me.ListBox1.List(i, 0)

        rst.Open qry, cnn, adOpenKeyset, adLockOptimistic

    End If

Next i

cnn.Close

MsgBox "Deleted Successfully", vbInformation, ""

• Display userform data from listbox

On Error Resume Next

If Me.ListBox1.ListIndex >= 0 Then

  If Me.ListBox1.List(Me.ListBox1.ListIndex, 0) <> "" Then

    Me.txtId.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 0)

    Me.TextBox2.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 3)

    Me.TextBox3.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 4)

   Me.TextBox4.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 5)

    End If

Else

MsgBox "Please select a record to update", vbCritical, ""

End If

• Frame show, hide, position

Frame8.Left = 468

Frame6.Visible = False

Frame7.Visible = True

• Listbox show, hide, position

ListBox1.Visible = False

ListBox1.Visible = True

ListBox1.Left = 468

• CommandButton show, hide, position

CommandButton26.Visible = True

CommandButton25.Visible = False

CommandButton25.Left = 468

• Date picker from calendar

Dim sDate As String

   On Error Resume Next

    sDate = MyCalendar.DatePicker(Me.TextBox12)

    Me.TextBox12.Value = Format(sDate, "dd-Mmm-yy")

    On Error GoTo 0

    TextBox12.SetFocus

• ComboBox add item from Worksheet with two column without duplicate value and filter as Ascending order

Dim ssh As Worksheet

Set ssh = ThisWorkbook.Sheets("Manpower_QA")

Dim n As Long

For n = 2 To ssh.Range("A" & Application.Rows.Count).End(xlUp).row

If Application.WorksheetFunction.CountIf(ssh.Range("A2", "A" & n), ssh.Cells(i, 1)) = 1 Then

With Me.ComboBox1

.AddItem ssh.Cells(n, 1)

.List(.ListCount - 1, 1) = ssh.Cells(n, 3).Offset(0, 1).Value

End With

End If

Next n

ssh.UsedRange.Sort key1:=ssh.Range("A1"), order1:=xlAscending, Header:=xlYes

• ComboBox add item from Worksheet with single column and filter as Ascending order

Dim ssh As Worksheet

Set ssh = ThisWorkbook.Sheets("Manpower_QA")

Dim n As Long

For n = 2 To ssh.Range("A" & Application.Rows.Count).End(xlUp).row

With Me.ComboBox1

.AddItem ssh.Cells(n, 1)

End With

Next n

ssh.UsedRange.Sort key1:=ssh.Range("A1"), order1:=xlAscending, Header:=xlYes

• ComboBox add item from Worksheet with two column value and filter as Ascending order

Dim ssh As Worksheet

Set ssh = ThisWorkbook.Sheets("Manpower_QA")

Dim n As Long

For n = 2 To ssh.Range("A" & Application.Rows.Count).End(xlUp).row

With Me.ComboBox1

.AddItem ssh.Cells(n, 1)

.List(.ListCount - 1, 1) = ssh.Cells(n, 3).Offset(0, 1).Value

End With

Next n

ssh.UsedRange.Sort key1:=ssh.Range("A1"), order1:=xlAscending, Header:=xlYes

• ComboBox add item manual

With Me.ComboBox2

         .AddItem "ALL"

        .AddItem "Date"

        .AddItem "Name_Of_Product"

        .AddItem "Batch"

        .AddItem "Related_Area"

        .AddItem "Informed_To_Name"

        .AddItem "Observed_By"

        .AddItem "Observed_Date"

        .Value = "ALL"

    End With

 Me.ComboBox2..AddItem "ALL"

ComboBox2..AddItem "ALL"

• Worksheet data filter as Ascending order or Descending order with header

Dim ssh As Worksheet

Set ssh = ThisWorkbook.Sheets("Manpower_QA")

ssh.UsedRange.Sort key1:=ssh.Range("A1"), order1:=xlAscending, Header:=xlYes

ssh.UsedRange.Sort key1:=ssh.Range("A1"), order1:=xlAscending, Header:=xlYes

• Userform full screen

Application.WindowState = xlMaximized

Userform.Zoom = Int(Application.Width / Userform.Width * 100)

Userform.startupposition = 0

Userform.Left = Application.Left

Userform.Top = Application.Top

Userform.Width = Application.Width

Userform.Height = Application.Height

• Userform Maximized

Private Sub btn_Maximize_Click()

Application.WindowState = xlMaximized

Observation.Left = Application.Left

Observation.Top = Application.Top

Observation.Width = Application.Width

Observation.Height = Application.Height

Me.btn_Maximize.Visible = False

Me.btn_Minimize.Visible = True

End Sub

• Userform Minimized

Private Sub btn_Minimize_Click()

Observation.Left = Application.Left

Observation.Top = Application.Height - 100

Observation.Width = 20

Observation.Height = 60

Me.btn_Maximize.Visible = True

Me.btn_Minimize.Visible = False

End Sub

• Show ListBox Data

Sub List_box_Data()

On Error Resume Next

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

sh.Cells.ClearContents

Dim cnn As New ADODB.Connection

Dim rst As New ADODB.Recordset

'Dim STDate, ENDate As Date

Dim qry As String, i As Integer

Dim n As Long

If Me.ComboBox2.Value = "ALL" Then

    qry = "SELECT * FROM TBL_Sample"

Else

    qry = "SELECT * FROM TBL_Sample WHERE " & Me.ComboBox2.Value & " LIKE '%" & Me.TextBox33.Value & "%'"

End If

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ("\\172.23.89.105\Anomalies Identification & Action taken$") & "\DatabaseQA.accdb"

or

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

rst.Open qry, cnn, adOpenKeyset, adLockOptimistic

sh.Range("A2").CopyFromRecordset rst

For i = 1 To rst.Fields.Count

    sh.Cells(1, i).Value = rst.Fields(i - 1).Name

Next i

rst.Close

cnn.Close

    sh.Range("B:B").NumberFormat = "dd-Mmm-yy"

    sh.Range("C:C").NumberFormat = "HH:MM:SS" ' AM/PM"

    'sh.Range("Q:Q").NumberFormat = "dd-Mmm-yy"

    'sh.Range("R:R").NumberFormat = "dd-Mmm-yy"

With Me.ListBox1

    .ColumnCount = 15

    .ColumnHeads = True

    .ColumnWidths = "0,50,50,80,50,60,0,0,100,0,0,0,0,100,70"

n = sh.Range("A" & Application.Rows.Count).End(xlUp).row

If n > 1 Then

.RowSource = "Support!A2:O" & n

Else

.RowSource = "Support!A2:O2"

End If

End With

sh.UsedRange.Sort key1:=sh.Range("B1"), order1:=xlDescending, Header:=xlYes

End Sub

• Userform Query Close

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

Dim App As Excel.Application

Unload Me

ThisWorkbook.Close savechanges:=False

App.Quit

Set App = Nothing

End Sub

• ListBox Data Ascending order

On Error Resume Next

    Dim n As Integer

    Dim sh As Worksheet

    Set sh = ThisWorkbook.Sheets("Support")

    n = Application.WorksheetFunction.Match(Me.ComboBox10.Value, sh.Range("1:1"), 0)

    sh.UsedRange.Sort key1:=sh.Cells(1, n), order1:=xlAscending, Header:=xlYes

• ListBox Data Descending order

On Error Resume Next

    Dim n As Integer

    Dim sh As Worksheet

    Set sh = ThisWorkbook.Sheets("Support")

    n = Application.WorksheetFunction.Match(Me.ComboBox10.Value, sh.Range("1:1"), 0)

    sh.UsedRange.Sort key1:=sh.Cells(1, n), order1:=xlDescending, Header:=xlYes

• Login module, Data connect from MS access database

Sub User_Login(User_Id As String, Password As String)

    On Error GoTo 0

    Dim cnn As New ADODB.Connection

    Dim rst As New ADODB.Recordset

    Dim qry As String

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ("\\172.23.89.105\Anomalies Identification & Action taken$") & "\DatabaseQA.accdb"

or

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

   qry = "SELECT * FROM TBL_UM WHERE User_ID = '" & User_Id & "'"

    rst.Open qry, cnn, adOpenKeyset, adLockOptimistic

    If rst.RecordCount = 0 Then

        MsgBox "Incorrect User Id", vbCritical, "???"

    ElseIf rst.Fields("Password").Value = Password Then

       'MsgBox "Login successfully", vbInformation, ""

      UserLogin.Hide

       Userform.Show

  Else

        MsgBox "Incorrect password", vbCritical, "???"

    End If

    rst.Close

    cnn.Close

End Sub

• Convert text Uppercase, Lowercase, Proper case

ThisWorkbook.Sheets("Sheet1").Range("B1").Value = StrConv(Me.TextBox1.Value), vbProperCase

ThisWorkbook.Sheets("Sheet1").Range("B1").Value = StrConv(Me.TextBox1.Value), vbUpperCase

ThisWorkbook.Sheets("Sheet1").Range("B1").Value = StrConv(Me.TextBox1.Value), vbLowerCase

• Remove blank space before or after text

ThisWorkbook.Sheets("Sheet1").Range("B1").Value = Trim(Me.TextBox1.Value)

• Remove blank space before or after text and convert text case

ThisWorkbook.Sheets("Sheet1").Range("B1").Value = StrConv(Trim(Me.TextBox1.Value), vbProperCase)

• Maximum number target during login

Static X As Integer

X = X + 1

If X >= 3 Then

MsgBox "You have tried maximum number", vbInformation, "????"

• Backup folder or files

Open notepad and write

xcopy "\\172.23.89.75\pmqc$" "\\squaregroup.com\pufiles\QCD\Alim2\PMQC$" /Y /E /D /C /F /H /I /Z /J

save as fileName.bat format

run the file

• ListBox data count

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support2")

n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

If (n - 1) < 2 Then

    Me.lbl_record_count.Caption = (n - 1) & " Record"

ElseIf (n - 1) > 1 Then

    Me.lbl_record_count.Caption = (n - 1) & " Records"

End If

• Save data path selection

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ("\\172.23.89.105\Anomalies Identification & Action taken$") & "\DatabaseQA.accdb"

• Active workbook close and another workbook open

On Error Resume Next

Application.ScreenUpdating = False

Dim tr As String

tr = ThisWorkbook.Name

Workbooks.Open FileName:="\\172.23.89.75\Training Record\Print training record.xlsb"

Workbooks.Open FileName:="D:\My Creation\Training Record\Print training record.xlsb"

Workbooks(tr).Close savechanges:=True

• TextBox value depend on ComboBox value collect from worksheet

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("SOP")

Dim i As Long

For i = 2 To sh.Range("B4000").End(xlUp).Row

If sh.Cells(i, 1) = Me.ComboBox3 Then

Me.TextBox2.Value = sh.Cells(i, 2)

Me.TextBox3.Value = sh.Cells(i, 4)

Me.TextBox4.Value = sh.Cells(i, 10)

End If

Next i

• This WorkBook save, close and Quit Application

Unload Me

ThisWorkbook.Save

Application.Quit

• Download data from listBox to new workbook

ThisWorkbook.Save

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

Dim nwb As Workbook

Dim nsh As Worksheet

Set nwb = Workbooks.Add

Set nsh = nwb.Sheets(1)

sh.UsedRange.Copy nsh.Range("A1")

• CheckBox True/False, Locked

CheckBox2.locked=Ture

CheckBox2.locked=False

CheckBox3 = False

CheckBox4 = True

• TextBox/ComboBox value compare

If TextBox17.Value <> "" Then

If TextBox17.Value = "" Then

If TextBox17.Value = 50 Then

If TextBox17.Value > 50 Then

If TextBox17.Value < 50 Then

If TextBox17.Value >= 50 Then

If TextBox17.Value <=50 "" Then

• Upload Image from Directory

Sub UploadImages_PMD()

   Dim CommodityName As String, T As String

   myDir = ("\\172.23.89.75\pmqc$") & "\Barcode\"

   CommodityName = Sheets("PMD").Range("AA10")

   T = ".jpg"

   On Error GoTo errormessage:

        Sheets("PMD").Shapes.AddPicture FileName:=myDir & CommodityName & T, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=Sheets("PMD").Range("N10").Left, Top:=162, Width:=77, Height:=17

errormessage:

If Err.Number = 1004 Then

Exit Sub

MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"

 End If

End Sub

• Search data between two dates, Date Range

On Error Resume Next

Application.ScreenUpdating = False

     Dim sh As Worksheet ' Database sheet

    Dim sht As Worksheet 'SearchData sheet

    Set sh = ThisWorkbook.Sheets("Support")

    Set sht = ThisWorkbook.Sheets("SearchData")

    Dim ish As Long 'for the last non-blank row number available in Database sheet

    Dim isht As Long 'for the last non-blank row number available in SearachData sheet

    ish = ThisWorkbook.Sheets("Support").Range("A" & Application.Rows.Count).End(xlUp).Row

   If sh.FilterMode = True Then

      sh.AutoFilterMode = False

    End If

If Me.TextBox_Start_Date = "" Or Me.TextBox_End_Date = "" Then

MsgBox "Please input Date period", vbOKOnly, "Blank!!!"

Exit Sub

End If

'condition1

If Me.CMB_Type.Value = "" Then

        sh.Range("A1:O" & ish).AutoFilter Field:=3, Criteria1:=">=" & CDate(Me.TextBox_Start_Date.Value) _

        , Criteria2:="<=" & CDate(Me.TextBox_End_Date.Value) + 1

End If

'con 2

If Me.CMB_Type.Value <> "" Then

        sh.Range("A1:O" & ish).AutoFilter Field:=3, Criteria1:=">=" & CDate(Me.TextBox_Start_Date.Value) _

        , Criteria2:="<=" & CDate(Me.TextBox_End_Date.Value) + 1

            sh.Range("A1:O" & ish).AutoFilter Field:=6, Criteria1:=Me.CMB_Type.Value

End If

        Me.TextBox6.Value = ""

        sht.Cells.Clear

        sh.AutoFilter.Range.Copy sht.Range("A1")

        Application.CutCopyMode = False

        isht = sht.Range("A" & Application.Rows.Count).End(xlUp).Row

        Me.ListBox1.ColumnCount = 20

        Me.ListBox1.ColumnHeads = True

        Me.ListBox1.ColumnWidths = "0,55,65,100,210,55,95,0,0,0,0,95,0,0,0,0"

        sht.UsedRange.Sort key1:=sht.Range("B1"), order1:=xlAscending, Header:=xlYes

  'condition msgbox if data found

    If isht > 1 Then

            Me.ListBox1.RowSource = "SearchData!A2:O" & isht

            'MsgBox "Record found.", vbInformation, "!!!"

   Else

    MsgBox "No record found.", vbInformation, "!!!"

    Me.ListBox1.RowSource = "SearchData!A2:O" & isht

End If

    sh.AutoFilterMode = False

    Application.ScreenUpdating = False

    Me.TextBox6.Value = Me.ListBox1.ListCount - 1 + 1 & " Records"

• Non-visible share folder

FolderName$

• Merge cell

Application.ScreenUpdating = False

    Range("B1:C3").Merge Across:=False

    Range("D1:R3").Merge Across:=False

    Range("S1:U3").Merge Across:=False

If Range("E18") <> "" Then Range("E18:O18").Merge

• Date Wise Search

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Support")

Dim dsh As Worksheet

Set dsh = ThisWorkbook.Sheets("Data_Display")

Dim LastRow As Long

''''''''''' Copy Data ''''''''''

dsh.Cells.Clear

sh.AutoFilterMode = False

'If Me.ComboBox1.Value <> "All" Then

    If Me.ComboBox3.Value = "Date" Then

            LastRow = dsh.Range("B" & Rows.Count).End(xlUp).Row

        If dsh.Range("B:B").Value >= Me.TextBox2.Value And _

           dsh.Range("B:B").Value <= Me.TextBox3.Value Then

          dsh.UsedRange.AutoFilter Application.WorksheetFunction.Match(Me.TextBox2.Value, dsh.Range("2:2"), 0), ""

        End If

     End If

sh.UsedRange.Copy dsh.Range("A1")

sh.AutoFilterMode = False

Dim lr As Long

lr = Application.WorksheetFunction.CountA(dsh.Range("A:A"))

If lr = 1 Then lr = 2

With Me.ListBox1

    .ColumnHeads = True

    .ColumnCount = 20

    .ColumnWidths = "0,55,65,100,210,55,95,0,0,0,0,95,0,0,0,0"

    .RowSource = "Data_Display!A2:O" & lr

End With

• Search Last Row

Dim dsh As Worksheet

Set dsh = ThisWorkbook.Sheets("Data_Display")

Dim LastRow As Long

            LastRow = dsh.Range("B" & Rows.Count).End(xlUp).Row

• Autofilter mode false

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Data_Display")

sh.AutoFilterMode = False

• Autofilter mode true

Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Data_Display")

sh.AutoFilterMode = True

• Textbox or Combobox return value date format for listbox

Me.ComboBox5.Value = VBA.Format(Me.ListBox1.List(Me.ListBox1.ListIndex, 15), "dd Mmm yyyy")

• Userform initially Textbox or Combobox default date value and date format

Print_training_record.TextBox_Start_Date.Value = Format(Date, "dd-Mmm-yy")

• Autofilter/ Filter matching criteria

Dim sh As Worksheet ' Database sheet  

Dim ssh As Worksheet ' Database sheet

Set sh = ThisWorkbook.Sheets("SOP")

Set ssh = ThisWorkbook.Sheets("GxP")

Dim ish As Long 'for the last non-blank row number available in Database sheet

Dim issh As Long 'for the last non-blank row number available in Database sheet

ish = ThisWorkbook.Sheets("SOP").Range("A" & Application.Rows.Count).End(xlUp).Row

issh = ThisWorkbook.Sheets("GxP").Range("A" & Application.Rows.Count).End(xlUp).Row

If Me.CMB_Type.Value <> "" Then

       sh.Range("A1:G" & ish).AutoFilter Field:=1, Criteria1:=Me.CMB_Type.Value

       ssh.Range("A1:Z" & issh).AutoFilter Field:=1, Criteria1:=Me.CMB_Type.Value

End If

• Copy Paste from one sheet to another sheet after autofilter

Dim sh As Worksheet 

Dim sht As Worksheet 

Set sh = ThisWorkbook.Sheets("SOP")

Set sht = ThisWorkbook.Sheets("GxP")

sh.AutoFilter.Range.Copy sht.Range("A1")

• Text Length calculate

If Me.TextBox1.Value = "" Or Len(Me.TextBox1.Value) < 8 Or Not IsNumeric(Me.TextBox1.Value) Then

MsgBox "Please enter 8 digit Patient ID first", vbCritical, "Invalid entry!!!"

Exit Sub

End If

• File directory existence check

Dim FileName As String

     FileName = ThisWorkbook.Path & "\Database.xlsm"

     'Check File Exist or Not

      If Dir(FileName) = "" Then

           MsgBox "Database File is missing. Unable to proceed.", vbOKOnly + vbCritical, "Error"

     Exit Sub

       End If

• File is in use check

Dim App As New Excel.Application

Dim wBook As Excel.Workbook

       Dim FileName As String

         FileName = ThisWorkbook.Path & "\Database.xlsm"

       Set wBook = App.Workbooks.Open(FileName)

       App.Visible = False

       If wBook.ReadOnly = True Then

        MsgBox "Database is in use. Please try after sometimes.", vbOKOnly + vbCritical, "Database Busy"

     Exit Sub

End If

• Save data using excel database

If Me.TextBox1.Value = "" Or Len(Me.TextBox1.Value) < 8 Or Not IsNumeric(Me.TextBox1.Value) Then

    MsgBox "Please enter 8 digit Patient ID first", vbCritical, "Invalid entry!!!"

Exit Sub

End If

If Me.TextBox2.Value = "" Then

    MsgBox "Please enter C/C", vbCritical, "Blank !!!"

Exit Sub

End If

Application.ScreenUpdating = True

    Dim App As New Excel.Application

Dim wBook As Excel.Workbook

    Dim FileName As String

    FileName = ThisWorkbook.Path & "\Database.xlsm"

    Set wBook = App.Workbooks.Open(FileName)

    App.Visible = False

     With wBook.Sheets("Database")

Dim row_number As Long

Dim max_id As Long

max_id = Application.WorksheetFunction.Max(.Range("A:A"))

If Me.txt_id.Value = "" Then  

    row_number = Application.WorksheetFunction.CountA(.Range("A:A")) + 1

.Range("A" & row_number).Value = max_id + 1

.Range("H" & row_number).Value = Now

.Range("B" & row_number).Value = VBA.Date

Else                      '''' Update

    row_number = Application.WorksheetFunction.Match(Int(Me.txt_id.Value), .Range("A:A"), 0)

End If

.Range("C" & row_number).Value = "'" & Me.TextBox1.Value

.Range("D" & row_number).Value = Me.TextBox2.Value

.Range("E" & row_number).Value = Me.TextBox3.Value

End With

 wBook.Close Savechanges:=True

 App.Quit

 Set App = Nothing

'Reset the form

Application.ScreenUpdating = True

Me.TextBox1.Value = ""

Me.TextBox2.Value = ""

Me.TextBox3.Value = ""

Me.TextBox4.Value = ""

MsgBox "Done", vbInformation

• Find last row in a column

Dim LastRow As Long

LastRow = Thisworkbook.Sheets("SOP").Range("A" & Application.Rows.Count).End(xlUp).Row

• Visible veryhidden sheet

ThisWorkbook.Sheets("Print").Visible = xlVeryHidden

• User from Query Close button off

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

If CloseMode = vbFormControlMenu Then

        MsgBox "Please click on back button", vbCritical, "Do you want to close?"

     Cancel = True

End If

End Sub