Advance Excel

Advanced Excel Tricks and Tips 

Simple macro code for collate data

Sub simpleXlsMerger()

Dim bookList As Workbook

Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")

 

'change folder path of excel files here

Set dirObj = mergeObj.Getfolder("C:\Users\chetanc\Desktop\Collate\Collate")

Set filesObj = dirObj.Files

For Each everyObj In filesObj

Set bookList = Workbooks.Open(everyObj)

 

'change "A2" with cell reference of start point for every files here

'for example "B3:IV" to merge all files start from columns B and rows 3

'If you're files using more than IV column, change it to the latest column

'Also change "A" column on "A65536" to the same column as start point

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy

ThisWorkbook.Worksheets(1).Activate

 

'Do not change the following column. It's not the same column as above

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial

Application.CutCopyMode = False

bookList.Close

Next

End Sub

Download File

Advanced Macro for data collate 

Advance macro for data collate, extreamly advanced vba macro only need execution for collate the data from different sheets in one sheet.

Download File

***********************************************************************************

Merge multiple sheets into one

Select and paste multiple sheets in one sheet (Merge)

Public Sub Consolidate()

    Dim i As Integer

    

    For i = 1 To Worksheets.Count - 1

    

    Worksheets(i).Select

    Range("a2").Select

    Range(Selection, Selection.End(xlDown)).Select

    Range(Selection, Selection.End(xlToRight)).Select

    Selection.Copy

    

    Worksheets("report").Select

    Range("A1048576").Select

    Selection.End(xlUp).Select

    ActiveCell.Offset(1, 0).Select

    ActiveSheet.Paste

    

    Next i

End Sub

Download File

***********************************************************************************

Select multiple column in VBA mode (Macro)

Sub FindAddressColumn()

'Updateby Extendoffcie

    Dim xRg As Range

    Dim xRgUni As Range

    Dim xFirstAddress As String

    Dim xStr As String

    On Error Resume Next

    xStr = "Numb"

    Set xRg = Range("A1:Z1").Find(xStr, , xlValues, xlWhole, , , True)

    If Not xRg Is Nothing Then

        xFirstAddress = xRg.Address

        Do

            Set xRg = Range("A1:P1").FindNext(xRg)

            If xRgUni Is Nothing Then

                Set xRgUni = xRg

            Else

                Set xRgUni = Application.Union(xRgUni, xRg)

            End If

        Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)

    End If

    xRgUni.EntireColumn.Select

    

    Dim xRg2 As Range

    Dim xRgUni2 As Range

    Dim xFirstAddress2 As String

    Dim xStr2 As String

    On Error Resume Next

    xStr2 = "Name"

    Set xRg2 = Range("A1:Z1").Find(xStr2, , xlValues, xlWhole, , , True)

    If Not xRg2 Is Nothing Then

        xFirstAddress = xRg2.Address

        Do

            Set xRg2 = Range("A1:P1").FindNext(xRg2)

            If xRgUni Is Nothing Then

                Set xRgUni = xRg2

            Else

                Set xRgUni = Application.Union(xRgUni, xRg2)

            End If

        Loop While (Not xRg2 Is Nothing) And (xRg2.Address <> xFirstAddress)

    End If

    xRgUni.EntireColumn.Select

   Dim xRg3 As Range

    Dim xRgUni3 As Range

    Dim xFirstAddress3 As String

    Dim xStr3 As String

    On Error Resume Next

    xStr3 = "Price"

    Set xRg3 = Range("A1:Z1").Find(xStr3, , xlValues, xlWhole, , , True)

    If Not xRg3 Is Nothing Then

        xFirstAddress = xRg3.Address

        Do

            Set xRg3 = Range("A1:P1").FindNext(xRg3)

            If xRgUni Is Nothing Then

                Set xRgUni = xRg3

            Else

                Set xRgUni = Application.Union(xRgUni, xRg3)

            End If

        Loop While (Not xRg3 Is Nothing) And (xRg3.Address <> xFirstAddress)

    End If

    xRgUni.EntireColumn.Select

    

End Sub

***********************************************************************************

31 Important Excel Functions 

FREQUENCY	INDEX & MATCH	LOOKUP	VLOOKUP	HLOOKUP
SUMIF	SUMIFS	COUNTIF	COUNTIFS	COUNTA & COUNTBLANK
AVERAGEIF & AVERAGE IFS	SUBTOTAL	SUMPRODUCT	IF FORMULA	NESTED IF
LEFT, MID, RIGHT & FIND	REPEAT	SUBSTITUTE	PMT,IPMT, PPMT, PV, FV

31 important excel formulas with their practical example.

Download File

***********************************************************************************

Calculate Exact Year, Month, Days from Date of Birth In Excel

Formula: 

Years:

=DATEDIF(D4,TODAY(),"Y")       (Change D4 to your date of Birth) 

Months :

=DATEDIF(D4,TODAY(),"YM")

Days:

=DATEDIF(D4,TODAY(),"MD")

***********************************************************************************

Download file

***********************************************************************************

15 Excel Combo 

=TRIM(CLEAN(SUBSTITUTE(E3,CHAR(160),CHAR(32))))

=TRIM(CLEAN(PROPER(E2)))

=IF(P2>80,"Execlent",IF(P2>=80,"Good",IF(P2<80,"Poor")))

=IF(P15>0,MAX(O14:O14)+1,"")

=IF(AND(C5>=18,D5>=18,E5>=18,F5>=18,G5>=18),"Pass","Fail")

=IF(M6>0,L5+1,"")

=IF(H5<=24,"Poor",IF(H5<=54,"Need Improvement",IF(H5<=74,"Good",IF(H5<=100,"Excellent"))))

=IF(H5<=24,"D",IF(H5<=54,"C",IF(H5<=74,"B",IF(H5<=100,"A"))))

=COUNTIF(C5:G5,">=30")

=IF(COUNTIF(D5:H5,">=30")=5,"Pass","Fail")

=IFERROR(K14,"Invalid number")

=FIND("@",J2,1)

=RIGHT(J2,LEN(J2)-K2)

=LEFT(J2,L2-1)

=TEXT(WEEKDAY(B2,1),"DDDD")

Download File

**************************************************************************************************************

***********************************************************************************

Vlookup on Duplicate values

Unique IDs using COUNTIF

Let’s say we want to lookup the second score for Student ID = 2021-A in this dataset:

First, we will create unique IDs in column B by joining the original student ID (column C) with a COUNTIF Function:

=C3&"-"&COUNTIF($C$3:C3,C3)

The COUNTIF Function counts the number of each Student ID. By locking one cell reference in the COUNTIF Function, but not the other, we identify each instance of a duplicate Student ID with a unique number:

=COUNTIF($C$3:C3,C3)

Then we simply use the & operate to concatenate everything together as in the previous formula.

***********************************************************************************

Vlookup Cheat Sheet

***********************************************************************************

Randomization

Randomization between character text or number
Random Number 100 - 500  :  =RANDBETWEEN(100,500)
Random Number Decimal 1 - 50 : =RANDBETWEEN(1*10,50*10)/10  
Random Dates 1-Jul-2021 to 31-Jul-2021 : =RANDBETWEEN(DATEVALUE("1-July-2021"),DATEVALUE("31-July-2021")) 
Random time between 9:00 AM to 6:30 PM : =TIME(9,0,0)+RAND()*TIME(18,30,0)-TIME(9,0,0) Random Alphabet between A to Z : =CHAR(RANDBETWEEN(CODE("A"),CODE("Z")))
Random text string/ password :  =RANDBETWEEN(0,9)&CHAR(RANDBETWEEN(65,90))&CHAR(RANDBETWEEN(97,122))&CHAR(RANDBETWEEN(33,47))
Random Names :  =CHOOSE(RANDBETWEEN(1,9),$A$26,$A$27,$A$28,$A$29,$A$30,$A$31,$A$32,$A$33,$A$34)

Download File

******************************************************************************************

VBA for Macro(Professional)

Sub Get_Data_From_File()

    Dim FileToOpen As Variant

    Dim OpenBook As Workbook

    Application.ScreenUpdating = False

    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")

    If FileToOpen <> False Then

        Set OpenBook = Application.Workbooks.Open(FileToOpen)

        OpenBook.Sheets(1).Range("A1:E20").Copy

        ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues

        OpenBook.Close False

 

    End If

    Application.ScreenUpdating = True

End Sub

Download File

Sub Get_Data_From_File()

    Dim FileToOpen As Variant

    Dim OpenBook As Workbook

    Application.ScreenUpdating = False

    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")

    If FileToOpen <> False Then

        Set OpenBook = Application.Workbooks.Open(FileToOpen)

        OpenBook.Sheets(1).Range("A1:E20").Copy

         '----------------------------------------

         

        Dim ws As Worksheet

        Set ws = ThisWorkbook.Worksheets("SelectFile")

       

        Dim nextRow As Integer

        nextRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1

        If nextRow = 0 Then nextRow = 10

        

         '----------------------------------------

        ws.Range("A" & nextRow).PasteSpecial xlPasteValues

        OpenBook.Close False

        Sheet2.Range("A" & nextRow).Select

    End If

    Application.ScreenUpdating = True

End Sub

VBA(Copy paste data/Append in sheet)

Sub selctRange1()

    Range("A2").Select

    Range(Selection, Selection.End(xlToRight)).Copy

    Range("I2").PasteSpecial

End Sub

Sub Selector()

    Range("A2").End(xlToRight).Select

    ActiveCell.End(xlToDown).Select

    Range(Selection, Selection.End(xlToLeft)).Copy

End Sub

Sub CopyRna()

Dim i As Integer

i = Range("A50000").End(xlUp).Row

MsgBox (i)

Range("A2: F" & i).Copy

Sheets("Dash").Select

Range("A50000").End(xlUp).Offset(1, 0).PasteSpecial

End Sub

Download File

Brouws File
Private Sub CommandButton1_Click()
Dim files
Dim FildialogueOpen As Office.FileDialog
Set FildialogueOpen = Application.FileDialog(msoFileDialogOpen)
FildialogueOpen.Show
files = FildialogueOpen.SelectedItems(1)

If files = "" Then
MsgBox "File not selected!"
Exit Sub
Else
Workbooks.Open (files)
End If
End Sub

Download File

Module1

Option Explicit

Sub RectangleRoundedCorners1_Click()

UserForm1.Show

Application.Visible = False

End Sub

Private Sub EditBTN_Click()

TextBox1.Text = TextBox11.Text

Dim I As Long

For I = 3 To Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row

    If Sheets("Sheet1").Cells(I, "B").Value = TextBox11.Text Then

        TextBox1.Text = Sheets("Sheet1").Cells(I, 2).Value

        TextBox2.Text = Sheets("Sheet1").Cells(I, 3).Value

        TextBox3.Text = Sheets("Sheet1").Cells(I, 4).Value

        TextBox4.Text = Sheets("Sheet1").Cells(I, 5).Value

        ComboBox1.Text = Sheets("Sheet1").Cells(I, 6).Value

        TextBox5.Text = Sheets("Sheet1").Cells(I, 7).Value

        TextBox6.Text = Sheets("Sheet1").Cells(I, 8).Value

        ComboBox2.Text = Sheets("Sheet1").Cells(I, 9).Value

        TextBox7.Text = Sheets("Sheet1").Cells(I, 10).Value

        TextBox8.Text = Sheets("Sheet1").Cells(I, 11).Value

        TextBox9.Text = Sheets("Sheet1").Cells(I, 12).Value

        TextBox10.Text = Sheets("Sheet1").Cells(I, 13).Value

    End If

Next

End Sub

Private Sub ListBox1_Click()

TextBox11 = ListBox1.Column(0)

End Sub

Private Sub OptionButton1_Click()

Application.Visible = True

End Sub

Private Sub OptionButton2_Click()

Application.Visible = False

End Sub

Private Sub ResetBTN_Click()

Unload Me

UserForm1.Show

End Sub

Private Sub SaveBTN_Click()

Dim LastRow As Long

Dim Wsheet As Worksheet

Set Wsheet = Sheet1

If WorksheetFunction.CountIf(Wsheet.Range("B3:B" & Rows.Count), Me.TextBox1.Text) > 0 Then

    LastRow = WorksheetFunction.Match(CLng(TextBox1.Text), Wsheet.Range("B:B"), 0)

Else

    LastRow = Wsheet.Range("B" & Rows.Count).End(xlUp).Row + 1

End If

With Wsheet

    .Cells(LastRow, 2).Value = TextBox1.Text

    .Cells(LastRow, 3).Value = TextBox2.Text

    .Cells(LastRow, 4).Value = TextBox3.Text

    .Cells(LastRow, 5).Value = TextBox4.Text

    .Cells(LastRow, 6).Value = ComboBox1.Text

    .Cells(LastRow, 7).Value = TextBox5.Text

    .Cells(LastRow, 8).Value = TextBox6.Text

    .Cells(LastRow, 9).Value = ComboBox2.Text

    .Cells(LastRow, 10).Value = TextBox7.Text

    .Cells(LastRow, 11).Value = TextBox8.Text

    .Cells(LastRow, 12).Value = TextBox9.Text

    .Cells(LastRow, 13).Value = TextBox10.Text

End With

ThisWorkbook.Save

MsgBox "Data Save"

On Error Resume Next

Me.ListBox1.RowSource = "Data"

Unload Me

UserForm1.Show

End Sub

Private Sub TextBox10_Change()

Me.TextBox10 = LCase(TextBox10)

End Sub

Private Sub TextBox11_Change()

Me.EditBTN.Visible = True

End Sub

Private Sub TextBox2_Change()

Me.TextBox2 = Application.WorksheetFunction.Proper(TextBox2)

End Sub

Private Sub TextBox3_Change()

Me.TextBox3 = Application.WorksheetFunction.Proper(TextBox3)

End Sub

Private Sub TextBox4_Change()

Me.TextBox4 = Application.WorksheetFunction.Proper(TextBox4)

End Sub

Private Sub TextBox5_AfterUpdate()

Me.TextBox5 = Format(TextBox5, "DD-MMM-YYYY")

End Sub

Private Sub TextBox5_Change()

End Sub

Private Sub TextBox6_Change()

Me.TextBox6 = Application.WorksheetFunction.Proper(TextBox6)

End Sub

Private Sub UserForm_Initialize()

On Error Resume Next

Me.ListBox1.RowSource = "Data"

Me.TextBox1.Value = Application.WorksheetFunction.Max(Sheets("Sheet1").Range("B:B")) + 1

ComboBox1.List = Array("Male", "Female")

ComboBox2.List = Array("A+", "A-", "B+", "B-", "AB+", "AB-", "O+", "O-")

Me.EditBTN.Visible = False

End Sub

Download File

Option Explicit

'''''''''''''''''''''Initialization'''''''''''''''

Private Sub UserForm_Initialize()

        cmbClass.List = Array("Nursery", "LKG", "UKG", 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

        cmbPreClass.List = Array("Nursery", "LKG", "UKG", 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

        Me.txtDate.Value = Format(Date, "YYYY-MMM-D")

        

        With txtRN

             .Value = Format(Val(Range("B" & Rows.Count).End(xlUp)) + 1, "0000")

             .Enabled = True

        End With

        

        Me.txtDOB.Value = "YYYY-MMM-D"

        Me.txtDOB.ForeColor = RGB(217, 217, 217)

        

        Me.txtSearch.Value = "Enter R.N."

        Me.txtSearch.ForeColor = RGB(217, 217, 217)

        

        txtSname.SetFocus

End Sub

Private Sub txtDOB_Enter()

        If Me.txtDOB.Value = "YYYY-MMM-D" Then

           Me.txtDOB.Value = ""

           Me.txtDOB.ForeColor = RGB(0, 0, 0)

        End If

End Sub

Private Sub txtDOB_Exit(ByVal Cancel As MSForms.ReturnBoolean)

        If Me.txtDOB.Value = "" Then

           Me.txtDOB.Value = "YYYY-MMM-D"

           Me.txtDOB.ForeColor = RGB(217, 217, 217)

        End If

End Sub

Private Sub txtSearch_Enter()

        If Me.txtSearch.Value = "Enter R.N." Then

           Me.txtSearch.Value = ""

           Me.txtSearch.ForeColor = RGB(0, 0, 0)

        End If

End Sub

Private Sub txtSearch_Exit(ByVal Cancel As MSForms.ReturnBoolean)

        If Me.txtSearch.Value = "" Then

           Me.txtSearch.Value = "Enter R.N."

           Me.txtSearch.ForeColor = RGB(217, 217, 217)

        End If

End Sub

'''''''''''''''''Validation'''''''''''''''''

Private Sub txtSname_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

        If (KeyAscii >= 65 And KeyAscii <= 90 Or KeyAscii >= 97 And KeyAscii <= 122 Or KeyAscii = 32) Then

            KeyAscii = KeyAscii

            Else

            KeyAscii = 0

        End If

End Sub

Private Sub txtPhone1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

        If (KeyAscii >= 48 And KeyAscii <= 57) Then

            KeyAscii = KeyAscii

            Else

            KeyAscii = 0

        End If

End Sub

Private Sub txtPhone2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

        If (KeyAscii >= 48 And KeyAscii <= 57) Then

            KeyAscii = KeyAscii

            Else

            KeyAscii = 0

        End If

End Sub

''''''''Reset Function''''''''''''''

Function Reset()

        Dim ctl As Control

        For Each ctl In Me.Controls

            Select Case TypeName(ctl)

                   Case "TextBox"

                        ctl.Value = ""

                   Case "OptionButton"

                        ctl.Value = False

                   Case "ComboBox"

                        ctl.ListIndex = -1

            End Select

         Next ctl

         

         Me.imgStudent.Picture = LoadPicture("")

         

End Function

''''''''''''''''''''' Upload Photo''''''''''''''''

Private Sub cmdUpload_Click()

        Dim Pic_Path As String

        Pic_Path = Application.GetOpenFilename(FileFilter:="JPG images, *.jpg, Bitmap Files, *.bmp", _

                   Title:="Please select an image", MultiSelect:=False)

        

        If Dir(Pic_Path) <> "" Then

           Me.txtImageURL.Value = Pic_Path

           Me.imgStudent.Picture = LoadPicture(Pic_Path)

        End If

End Sub

'''''''''''''''''''' Save Button  '''''''''''''''''''

Private Sub cmdSave_Click()

        Dim sh As Worksheet

        Set sh = ThisWorkbook.Sheets("Registration")

        Dim lr As Long

        lr = sh.Range("B" & Rows.Count).End(xlUp).Row

'''''''''''''''Validation'''''''''''''''

        If Me.txtSname.Value = "" Then

           MsgBox "Please enter the Student's name", vbOKOnly + vbInformation

           Exit Sub

        End If

        

        If Me.cmbClass.Value = "" Then

           MsgBox "Please enter the Class", vbOKOnly + vbInformation

           Exit Sub

        End If

        

        If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txtRN.Text) > 0 Then

           MsgBox "Data already exist!!!", vbOKOnly + vbInformation, "Error"

           Exit Sub

        End If

        

'''''''''''''''''Add Data in Excel Sheet'''''''''''''

       

       If MsgBox("Do you want to add data to worksheet?", vbYesNo + vbQuestion, "Question") = vbNo Then

           Exit Sub

        End If

       

       With sh

            .Cells(lr + 1, "B").Value = Me.txtRN.Value

            .Cells(lr + 1, "C").Value = Me.txtDate.Value

            .Cells(lr + 1, "D").Value = Me.txtSname.Value

            .Cells(lr + 1, "E").Value = Me.txtDOB.Value

            If optMale.Value = True Then

               .Cells(lr + 1, "F").Value = "Male"

            End If

            If optFemale.Value = True Then

               .Cells(lr + 1, "F").Value = "Female"

            End If

            .Cells(lr + 1, "G").Value = Me.cmbClass.Value

            .Cells(lr + 1, "H").Value = Me.txtReligion.Value

            .Cells(lr + 1, "I").Value = Me.txtSkills.Value

            .Cells(lr + 1, "J").Value = Me.txtFname.Value

            .Cells(lr + 1, "K").Value = Me.txtFQ.Value

            .Cells(lr + 1, "L").Value = Me.txtFO.Value

            .Cells(lr + 1, "M").Value = Me.txtMname.Value

            .Cells(lr + 1, "N").Value = Me.txtMQ.Value

            .Cells(lr + 1, "O").Value = Me.txtMO.Value

            .Cells(lr + 1, "P").Value = Me.txtSchoolName.Value

            .Cells(lr + 1, "Q").Value = Me.cmbPreClass.Value

            .Cells(lr + 1, "R").Value = Me.txtLastResults.Value

            .Cells(lr + 1, "S").Value = Me.txtTA.Value

            .Cells(lr + 1, "T").Value = Me.txtPA.Value

            .Cells(lr + 1, "U").Value = Me.txtPhone1.Value

            .Cells(lr + 1, "V").Value = Me.txtPhone2.Value

            .Cells(lr + 1, "W").Value = Me.txtEmail1.Value

            .Cells(lr + 1, "X").Value = Me.txtEmail2.Value

       End With

       

'''''''''''''''Add Image''''''''''''''''

       On Error Resume Next

       Dim img As String

           If Dir(ThisWorkbook.Path & Application.PathSeparator & "Student_Images", vbDirectory) = "" Then

             MkDir (ThisWorkbook.Path & Application.PathSeparator & "Student_Images")

           End If

       

       img = ThisWorkbook.Path & Application.PathSeparator & "Student_Images" & _

             Application.PathSeparator & Format(Me.txtRN.Value) & ".jpg"

       

       FileCopy Me.txtImageURL, img

       sh.Cells(lr + 1, "Y").Value = img

           Call Reset

           Call UserForm_Initialize

       

End Sub

''''''''''''''''Reset Button''''''''''''''''''''''''

Private Sub cmdReset_Click()

        If MsgBox("Do you want to Reset this form?", vbYesNo + vbQuestion + vbDefaultButton1, "Question") = vbYes Then

           Call Reset

           Call UserForm_Initialize

           txtSname.SetFocus

        End If

End Sub

''''''''''''''''''''''Exit Button''''''''''''''''''''''

Private Sub cmdExit_Click()

        If MsgBox("Do you want to exit this form?", vbYesNo + vbQuestion + vbDefaultButton1, "Question") = vbYes Then

           Unload Me

        End If

End Sub

'''''''''''''''''''''''''SearchButton''''''''''''''''''''''

Private Sub cmdSearch_Click()

        Dim sh As Worksheet

        Set sh = ThisWorkbook.Sheets("Registration")

        Dim lr As Long

        lr = sh.Range("B" & Rows.Count).End(xlUp).Row

        Dim i As Long

        

        If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txtSearch.Text) = 0 Then

           MsgBox "No match found!!!", vbOKOnly + vbInformation, "Error"

           Call Reset

           Call UserForm_Initialize

           txtSearch.SetFocus

           Exit Sub

        End If

        

        For i = 4 To lr

            If sh.Cells(i, "B").Value = txtSearch.Text Then

               txtRN = sh.Cells(i, "B").Value

               txtDate = sh.Cells(i, "C").Value

               txtSname = sh.Cells(i, "D").Value

               txtDOB = sh.Cells(i, "E").Value

               If sh.Cells(i, "F").Value = "Male" Then

                  optMale.Value = True

               End If

               If sh.Cells(i, "F").Value = "Female" Then

                  optFemale.Value = True

               End If

               cmbClass = sh.Cells(i, "G").Value

               txtReligion = sh.Cells(i, "H").Value

               txtSkills = sh.Cells(i, "I").Value

               txtFname = sh.Cells(i, "J").Value

               txtFQ = sh.Cells(i, "K").Value

               txtFO = sh.Cells(i, "L").Value

               txtMname = sh.Cells(i, "M").Value

               txtMQ = sh.Cells(i, "N").Value

               txtMO = sh.Cells(i, "O").Value

               txtSchoolName = sh.Cells(i, "P").Value

               cmbPreClass = sh.Cells(i, "Q").Value

               txtLastResults = sh.Cells(i, "R").Value

               txtTA = sh.Cells(i, "S").Value

               txtPA = sh.Cells(i, "T").Value

               txtPhone1 = sh.Cells(i, "U").Value

               txtPhone2 = sh.Cells(i, "V").Value

               txtEmail1 = sh.Cells(i, "W").Value

               txtEmail2 = sh.Cells(i, "X").Value

               txtImageURL = sh.Cells(i, "Y").Value

               If Dir(Me.txtImageURL.Value) <> "" Then

                  Me.imgStudent.Picture = LoadPicture(Me.txtImageURL.Value)

               

               End If

            End If

        Next i

        Me.txtDOB.ForeColor = RGB(0, 0, 0)

End Sub

'''''''''''''''''''''Update Button'''''''''''''''''''''''''

Private Sub cmdUpdate_Click()

        Dim sh As Worksheet

        Set sh = ThisWorkbook.Sheets("Registration")

        Dim lr As Long

        lr = sh.Range("B" & Rows.Count).End(xlUp).Row

        Dim i As Long

        

'''''''''''''''' Validation '''''''''''''''''''''''''''''

        If Me.txtSname.Value = "" Then

           MsgBox "Please enter the Student's name", vbOKOnly + vbInformation

           Exit Sub

        End If

        

        If Me.cmbClass.Value = "" Then

           MsgBox "Please enter the Class", vbOKOnly + vbInformation

           Exit Sub

        End If

        

'''''''''''''''Update data to excel file '''''''''''''''''''''

        If MsgBox("Do you want to update the data?", vbYesNo + vbQuestion, "Question") = vbNo Then

           Exit Sub

        End If

        

        For i = 4 To lr

            If sh.Cells(i, "B").Value = txtSearch.Text Then

            

               With sh

                   .Cells(i, "C").Value = Me.txtDate.Value

                   .Cells(i, "D").Value = Me.txtSname.Value

                   .Cells(i, "E").Value = Me.txtDOB.Value

                   If optMale.Value = True Then

                      .Cells(i, "F").Value = "Male"

                   End If

                   If optFemale.Value = True Then

                     .Cells(i, "F").Value = "Female"

                   End If

                   .Cells(i, "G").Value = Me.cmbClass.Value

                   .Cells(i, "H").Value = Me.txtReligion.Value

                   .Cells(i, "I").Value = Me.txtSkills.Value

                   .Cells(i, "J").Value = Me.txtFname.Value

                   .Cells(i, "K").Value = Me.txtFQ.Value

                   .Cells(i, "L").Value = Me.txtFO.Value

                   .Cells(i, "M").Value = Me.txtMname.Value

                   .Cells(i, "N").Value = Me.txtMQ.Value

                   .Cells(i, "O").Value = Me.txtMO.Value

                   .Cells(i, "P").Value = Me.txtSchoolName.Value

                   .Cells(i, "Q").Value = Me.cmbPreClass.Value

                   .Cells(i, "R").Value = Me.txtLastResults.Value

                   .Cells(i, "S").Value = Me.txtTA.Value

                   .Cells(i, "T").Value = Me.txtPA.Value

                   .Cells(i, "U").Value = Me.txtPhone1.Value

                   .Cells(i, "V").Value = Me.txtPhone2.Value

                   .Cells(i, "W").Value = Me.txtEmail1.Value

                   .Cells(i, "X").Value = Me.txtEmail2.Value

               End With

               '''''''''''''''Update Image''''''''''''''''

               On Error Resume Next

               Dim img As String

               If Dir(ThisWorkbook.Path & Application.PathSeparator & "Student_Images", vbDirectory) = "" Then

                  MkDir (ThisWorkbook.Path & Application.PathSeparator & "ImagesStudent_Images")

               End If

                  img = ThisWorkbook.Path & Application.PathSeparator & "Student_Images" & Application.PathSeparator _

                        & Format(Me.txtRN.Value) & ".jpg"

                  FileCopy Me.txtImageURL, img

                  sh.Cells(i, "Y").Value = img

            End If

       Next i

       

        Call Reset

        Call UserForm_Initialize

End Sub

'''''''''''''Delete Button''''''''''''''''''''''''

Private Sub cmdDelete_Click()

        Dim sh As Worksheet

        Set sh = ThisWorkbook.Sheets("Registration")

        Dim lr As Long

        lr = sh.Range("B" & Rows.Count).End(xlUp).Row

        Dim i As Long

        

        If MsgBox("Do you want to delete the data?", vbYesNo + vbQuestion, "Question") = vbNo Then

           Exit Sub

        End If

        

        For i = 4 To lr

            If sh.Cells(i, "B").Value = txtSearch.Text Then

               Rows(i).Delete

            End If

        Next i

        

        Call Reset

        Call UserForm_Initialize

End Sub

Download File

Download File

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim KeyCells As Range

    Dim ws As Worksheet

    Set ws = Worksheets("Sheet1")  ' Change "Sheet1" to the name of your sheet

    ' Define the target cell where you want to capture the start time

    Set KeyCells = ws.Range("A1")

    ' Check if the changed cell is the target cell

    If Not Application.Intersect(KeyCells, Target) Is Nothing Then

        If Target.Value <> "" And Target.Offset(0, 1).Value = "" Then

            ' If the target cell is not empty and the adjacent cell is empty, insert the current start time

            Target.Offset(0, 1).Value = Now

            Target.Offset(0, 1).NumberFormat = "mm/dd/yyyy hh:mm:ss AM/PM"  ' Adjust the format as needed

        ElseIf Target.Offset(0, 2).Value = "" Then

            ' If the target cell is not empty and the end time cell is empty, insert the current end time

            Target.Offset(0, 2).Value = Now

            Target.Offset(0, 2).NumberFormat = "mm/dd/yyyy hh:mm:ss AM/PM"  ' Adjust the format as needed

        End If

    End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim KeyCells As Range

    Dim ws As Worksheet

    Set ws = Worksheets("Sheet1")  ' Change "Sheet1" to the name of your sheet

    ' Define the target cell where you want to capture the time

    Set KeyCells = ws.Range("A1")

    ' Check if the changed cell is the target cell

    If Not Application.Intersect(KeyCells, Target) Is Nothing Then

        If Target.Value <> "" And Target.Offset(0, 1).Value = "" Then

            ' If the target cell is not empty and the adjacent cell is empty, insert the current time

            Target.Offset(0, 1).Value = Now

            Target.Offset(0, 1).NumberFormat = "mm/dd/yyyy hh:mm:ss AM/PM"  ' Adjust the format as needed

        End If

    End If

End Sub

***********************************************************************

Function MyTimestamp(Reference As Range)

If Reference.Value <> "" Then

MyTimestamp = Format(Now, "dd-mm-yyyy hh:mm:ss")

Else

MyTimestamp = ""

End If

End Function

Charts with Codes Download

*********************************************************************

Code for Userform

Just copy this code and paste in your Dashboard user form, You can design and follow the step as per the video.

 

Dim LblEvent(11) As New Class1

Private Sub UserForm_Initialize()

Application.Visible = False

Dim Pivt As PivotTable

Dim Slicer As SlicerCache

'Refresh Pivot Table

For Each Pivt In Sheet2.PivotTables

    Pivt.PivotCache.Refresh

Next

'Reset Slicer

For Each Slicer In ActiveWorkbook.SlicerCaches

    Slicer.ClearManualFilter

Next

For ChNo = 1 To 3

    FilePath = Environ$("Temp") & "\Chart" & ChNo & ".jpg"

    Sheet2.Activate

    Sheet2.Shapes("Chart" & ChNo).Select

    ActiveChart.Export FilePath

    Me("Img" & ChNo).Picture = LoadPicture(FilePath)

    Kill FilePath

Next ChNo

Me.TotSale = Format(Sheet2.Range("B1"), "STandard")

'Add Event

For AddEvent = 0 To 11

    Set LblEvent(AddEvent).LblBtn = Me("Label" & AddEvent + 1)

Next AddEvent

 

 

End Sub

 

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

Application.Visible = True

End Sub

 

 

Insert a Class Module and paste the following code

Public WithEvents LblBtn As MSForms.Label

 

Private Sub LblBtn_Click()

Dim Slicer As SlicerCache

BtnNo = Replace(LblBtn.Name, "Label", "")

 

If UserForm1.Controls("Image" & BtnNo).Visible = True Then

    UserForm1.Controls("ImageSec" & BtnNo).Visible = True

    UserForm1.Controls("Image" & BtnNo).Visible = False

Else

    UserForm1.Controls("ImageSec" & BtnNo).Visible = False

    UserForm1.Controls("Image" & BtnNo).Visible = True

End If

 

For Each Slicer In ActiveWorkbook.SlicerCaches

    If UserForm1.Controls("ImageSec" & BtnNo).Visible = True Then

        Slicer.SlicerItems(Left(LblBtn.Caption, 3)).Selected = False

    Else

    Slicer.SlicerItems(Left(LblBtn.Caption, 3)).Selected = True

    End If

Next

UserForm1.TotSale = Format(Sheet2.Range("B1"), "STandard")

For ChNo = 1 To 3

    FilePath = Environ$("Temp") & "\Chart" & ChNo & ".jpg"

    Sheet2.Activate

    Sheet2.Shapes("Chart" & ChNo).Select

    ActiveChart.Export FilePath

    UserForm1.Controls("Img" & ChNo).Picture = LoadPicture(FilePath)

    Kill FilePath

Next ChNo

End Sub

***********************************************************************************

Real working
Private Sub Workbook_Open()
    UserForm1.WindowState = xlMaximized
    UserForm1.Show
End Sub


Private Sub UserForm_Initialize()
Dim Pivt As PivotTable
'Refresh Pivot Table
For Each Pivt In Sheet2.PivotTables
    Pivt.PivotCache.Refresh
Next
For ChNo = 1 To 2
FilePath = VBA.Environ$("Temp") & "\Chart" & ChNo & ".jpg"
Sheet2.Activate
Sheet2.Shapes("Chart" & ChNo).Select
ActiveChart.Export FilePath
Me("Img" & ChNo).Picture = LoadPicture(FilePath)
Kill FilePath
Next ChNo

End Sub

Click toDownload

**********************************************************************************
Private Sub ComboBox1_Change()
    ' Determine the selected chart from ComboBox1 or ComboBox2
    If ComboBox1.Text = "Option 1" Then
    For ChNo = 1 To 2
         FilePath = VBA.Environ$("Temp") & "\Chart" & ChNo & ".jpg"
        Sheet2.Activate
        Sheet2.Shapes("Chart" & ChNo).Select
        ActiveChart.Export FilePath
        Me("Img" & ChNo).Picture = LoadPicture(FilePath)
        Kill FilePath
        Next ChNo
    ElseIf ComboBox1.Text = "Option 2" Then
    For ChNo = 1 To 2
         FilePath = VBA.Environ$("Temp") & "\Chart" & ChNo + 1 & ".jpg"
        Sheet2.Activate
        Sheet2.Shapes("Chart" & ChNo + 1).Select
        ActiveChart.Export FilePath
        Me("Img" & ChNo + 1).Picture = LoadPicture(FilePath)
        Kill FilePath
        Next ChNo
    Else
        Exit Sub ' No chart selected
    End If

End Sub

Private Sub UserForm_Initialize()
    ' Populate ComboBox with options
    ComboBox1.List = Array("Option 1", "Option 2")
    'ComboBox2.List = Array("Option 3", "Option 4")


Dim Pivt As PivotTable
'Refresh Pivot Table
For Each Pivt In Sheet2.PivotTables
    Pivt.PivotCache.Refresh
Next
End Sub

Click here to Download

*********************************************************************************

Private Sub ComboBox1_Change()

Application.ScreenUpdating = False

'On Error Resume Next

    ' Determine the selected chart from ComboBox1 or ComboBox2

    If ComboBox1.Text = "Option 1" Then

    For ChNo = 1 To 2

        Img3.Visible = False

        Img4.Visible = False

        Img1.Visible = True

        Img2.Visible = True

        FilePath = VBA.Environ$("Temp") & "\Chart" & ChNo & ".jpg"

        Sheet2.Activate

        Sheet2.Shapes("Chart" & ChNo).Select

        ActiveChart.Export FilePath

        Me("Img" & ChNo).Picture = LoadPicture(FilePath)

        Kill FilePath

        Next ChNo

    ElseIf ComboBox1.Text = "Option 2" Then

    For ChNo = 3 To 4

        Img3.Visible = True

        Img4.Visible = True

        Img1.Visible = False

        Img2.Visible = False

        FilePath = VBA.Environ$("Temp") & "\Chart" & ChNo & ".jpg"

        Sheet2.Activate

        Sheet2.Shapes("Chart" & ChNo).Select

        ActiveChart.Export FilePath

        Me("Img" & ChNo).Picture = LoadPicture(FilePath)

        Kill FilePath

        Next ChNo

    Else

        Exit Sub ' No chart selected

    End If

End Sub

Private Sub UserForm_Initialize()

    ' Populate ComboBox with options

    ComboBox1.List = Array("Option 1", "Option 2")

    'ComboBox2.List = Array("Option 3", "Option 4")

Dim Pivt As PivotTable

'Refresh Pivot Table

For Each Pivt In Sheet2.PivotTables

    Pivt.PivotCache.Refresh

Next

End Sub

Click here to Download

*******************************************************************

Sub UserFormShow()

UserForm1.Show

End Sub

Private Sub CommandButton1_Click()

    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet1")

    

    ' Check if Name and Age are not empty

    If Trim(Me.TextBox1.Value) = "" Or Trim(Me.TextBox2.Value) = "" Then

        MsgBox "Please enter Name and Age.", vbExclamation, "Validation Error"

        Exit Sub

    End If

    

    ' Find the last used row in column A

    Dim LastRow As Long

    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1

    

    ' Save data to Sheet1

    ws.Cells(LastRow, "A").Value = Me.TextBox1.Value ' Name textbox

    ws.Cells(LastRow, "B").Value = Me.TextBox2.Value ' Age textbox

    

    ' Clear text boxes after saving

    Me.TextBox1.Value = ""

    Me.TextBox2.Value = ""

    

    ' Show message box to confirm data saving

    MsgBox "Data saved successfully!", vbInformation, "Save Data"

End Sub

Private Sub CommandButton2_Click()

Unload Me

End Sub

Click here to Download

*******************************************************************

Click here to Download

*******************************************************************