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.

Code here 

Sub ConsolidateDataFromDifferentBooksInAFolder()
    Dim ReportBook As Workbook, DataBook As Workbook
    Dim ReportSheet As Worksheet, DataSheet As Worksheet
    Dim ReferPath As String, ReferFileName As String
    Dim Lr As Long, Lc As Long, RLr As Long
    Dim i As Long
    Dim FileType As String
    
    Application.ScreenUpdating = False
    Application.CutCopyMode = False
    ReferPath = ThisWorkbook.Path & "\EX20.00 - Data\" ' Path to the folder with data files
    
    Set ReportBook = ThisWorkbook
    Set ReportSheet = ReportBook.Worksheets("Sheet1")
    
    ' Get the first file in the folder
    ReferFileName = Dir(ReferPath & "*.*")
    
    ' Initialize the row counter for the report sheet
    RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row
    Do Until ReferFileName = ""
        ' Get the file extension
        FileType = LCase(Right(ReferFileName, Len(ReferFileName) - InStrRev(ReferFileName, ".")))
        ' Open Excel files (.xls, .xlsx, etc.)
        If FileType Like "xls*" Then
            Set DataBook = Workbooks.Open(ReferPath & ReferFileName)
            Set DataSheet = DataBook.Worksheets(1) ' Assuming data is in the first sheet
            
            ' Get the last row and column of the data sheet
            Lr = DataSheet.Cells(DataSheet.Rows.Count, "A").End(xlUp).Row
            Lc = DataSheet.Cells(1, DataSheet.Columns.Count).End(xlToLeft).Column
            
            If Lr > 1 Then ' If there's data to copy
                i = i + 1
                
                ' Copy and paste the data into the report sheet
                If i = 1 Then
                    ' Copy the entire range including headers
                    DataSheet.Range("A1").Resize(Lr, Lc).Copy
                    ReportSheet.Cells(RLr + 1, "B").PasteSpecial Paste:=xlPasteValues
                Else
                    ' Skip the header for subsequent files
                    DataSheet.Range("A2").Resize(Lr - 1, Lc).Copy
                    ReportSheet.Cells(RLr + 1, "B").PasteSpecial Paste:=xlPasteValues
                End If
                
                ' Insert the file name in column A
                ReportSheet.Cells(RLr + 1, "A").Resize(Lr).Value = ReferFileName
                
                ' Update the row counter
                RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row
                
                ' Clear clipboard to avoid extra memory usage
                Application.CutCopyMode = False
            End If
            
            ' Close the data workbook without saving
            DataBook.Close False
            
        ' Handle CSV files (.csv)
        ElseIf FileType = "csv" Then
            ' Import CSV data into the Report Sheet directly
            With ReportSheet.QueryTables.Add(Connection:="TEXT;" & ReferPath & ReferFileName, Destination:=ReportSheet.Cells(RLr + 1, "B"))
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileCommaDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileColumnDataTypes = Array(1, 1, 1) ' Assuming 3 columns of data (adjust based on actual data)
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileParseType = xlDelimited
                .Refresh BackgroundQuery:=False
            End With
            ' Update the row counter after importing CSV
            RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row
            ' Insert the file name in column A for the imported rows
            ReportSheet.Cells(RLr - Lr + 1, "A").Resize(Lr).Value = ReferFileName
        
        ' Handle TXT files (.txt)
        ElseIf FileType = "txt" Then
            ' Open the .txt file for reading line-by-line
            Dim FileNum As Integer
            Dim LineContent As String
            FileNum = FreeFile
            Open ReferPath & ReferFileName For Input As FileNum
            
            ' Read each line and copy it to the report sheet
            While Not EOF(FileNum)
                Line Input #FileNum, LineContent
                ' Split the line into columns assuming tab-delimited or comma-delimited
                DataArray = Split(LineContent, vbTab) ' Change delimiter if needed (use "," for CSV, vbTab for tab, etc.)
                
                ' Add each line to the report sheet
                For i = 0 To UBound(DataArray)
                    ReportSheet.Cells(RLr + 1, "B").Offset(0, i).Value = DataArray(i)
                Next i
                
                ' Insert the file name in column A
                ReportSheet.Cells(RLr + 1, "A").Value = ReferFileName
                
                RLr = RLr + 1 ' Increment the row counter
            Wend
            
            Close FileNum
        End If
        
        ' Get the next file
        ReferFileName = Dir
    Loop
    
    ' Optional: Clear any existing content in column A (except header)
    ReportSheet.Range("A:A").Replace ".*", ""
    
    ' Set the header for the file name column
    ReportSheet.Range("A1").Value = "File Name"
    
    ' Save the report workbook
    ReportBook.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data Consolidated Successfully", vbInformation
End Sub

Specific Buttonwise Collation

Private Sub btnTextFileCollate_Click()

    ' Call the collate function for text files

    Call CollateTextFiles

End Sub

Private Sub btnExcelFileCollate_Click()

    ' Call the collate function for Excel files

    Call CollateExcelFiles

End Sub

Private Sub btnCSVFileCollate_Click()

    ' Call the collate function for CSV files

    Call CollateCSVFiles

End Sub

Sub CollateTextFiles()

    Dim ReportBook As Workbook, ReportSheet As Worksheet

    Dim ReferPath As String, ReferFileName As String

    Dim Lr As Long, RLr As Long

    Dim FileNum As Integer

    Dim LineContent As String

    Dim DataArray() As String

    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    ReferPath = ThisWorkbook.Path & "\EX20.00 - Data\" ' Path to the folder with text files

    Set ReportBook = ThisWorkbook

    Set ReportSheet = ReportBook.Worksheets("Sheet1")

    ' Get the first text file in the folder

    ReferFileName = Dir(ReferPath & "*.txt")

    RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row

    Do Until ReferFileName = ""

        ' Open the text file for reading line-by-line

        FileNum = FreeFile

        Open ReferPath & ReferFileName For Input As FileNum

        

        ' Read each line and copy it to the report sheet

        While Not EOF(FileNum)

            Line Input #FileNum, LineContent

            ' Split the line into columns (assuming tab-delimited, change if needed)

            DataArray = Split(LineContent, vbTab)

            

            ' Add each line to the report sheet

            For i = 0 To UBound(DataArray)

                ReportSheet.Cells(RLr + 1, "B").Offset(0, i).Value = DataArray(i)

            Next i

            

            ' Insert the file name in column A

            ReportSheet.Cells(RLr + 1, "A").Value = ReferFileName

            RLr = RLr + 1 ' Increment the row counter

        Wend

        

        Close FileNum

        ReferFileName = Dir ' Get the next file

    Loop

    ReportSheet.Range("A1").Value = "File Name"

    ReportBook.Save

    Application.ScreenUpdating = True

    

    MsgBox "Text Files Merged Successfully", vbInformation

End Sub

Sub CollateExcelFiles()

    Dim ReportBook As Workbook, DataBook As Workbook

    Dim ReportSheet As Worksheet, DataSheet As Worksheet

    Dim ReferPath As String, ReferFileName As String

    Dim Lr As Long, Lc As Long, RLr As Long

    Dim i As Long

    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    ReferPath = ThisWorkbook.Path & "\EX20.00 - Data\" ' Path to the folder with Excel files

    Set ReportBook = ThisWorkbook

    Set ReportSheet = ReportBook.Worksheets("Sheet1")

    

    ReferFileName = Dir(ReferPath & "*.xls*")

    RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row

    Do Until ReferFileName = ""

        ' Open the Excel file

        Set DataBook = Workbooks.Open(ReferPath & ReferFileName)

        Set DataSheet = DataBook.Worksheets(1)

        ' Get the last row and column

        Lr = DataSheet.Cells(DataSheet.Rows.Count, "A").End(xlUp).Row

        Lc = DataSheet.Cells(1, DataSheet.Columns.Count).End(xlToLeft).Column

        If Lr > 1 Then

            i = i + 1

            If i = 1 Then

                ' Copy the entire range including headers

                DataSheet.Range("A1").Resize(Lr, Lc).Copy

                ReportSheet.Cells(RLr + 1, "B").PasteSpecial Paste:=xlPasteValues

            Else

                ' Skip header for subsequent files

                DataSheet.Range("A2").Resize(Lr - 1, Lc).Copy

                ReportSheet.Cells(RLr + 1, "B").PasteSpecial Paste:=xlPasteValues

            End If

            

            ' Insert the file name in column A

            ReportSheet.Cells(RLr + 1, "A").Resize(Lr).Value = ReferFileName

            

            ' Update row count

            RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row

            Application.CutCopyMode = False

        End If

        

        DataBook.Close False

        ReferFileName = Dir

    Loop

    

    ReportSheet.Range("A1").Value = "File Name"

    ReportBook.Save

    Application.ScreenUpdating = True

    

    MsgBox "Excel Files Merged Successfully", vbInformation

End Sub

Sub CollateCSVFiles()

    Dim ReportBook As Workbook, ReportSheet As Worksheet

    Dim ReferPath As String, ReferFileName As String

    Dim RLr As Long

    Application.ScreenUpdating = False

    Application.CutCopyMode = False

    ReferPath = ThisWorkbook.Path & "\EX20.00 - Data\" ' Path to the folder with CSV files

    Set ReportBook = ThisWorkbook

    Set ReportSheet = ReportBook.Worksheets("Sheet1")

    

    ReferFileName = Dir(ReferPath & "*.csv")

    RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row

    Do Until ReferFileName = ""

        ' Import CSV file using QueryTables

        With ReportSheet.QueryTables.Add(Connection:="TEXT;" & ReferPath & ReferFileName, Destination:=ReportSheet.Cells(RLr + 1, "B"))

            .TextFileConsecutiveDelimiter = False

            .TextFileTabDelimiter = False

            .TextFileCommaDelimiter = True

            .TextFileSemicolonDelimiter = False

            .TextFileColumnDataTypes = Array(1, 1, 1) ' Adjust if needed

            .TextFileTextQualifier = xlTextQualifierDoubleQuote

            .TextFileParseType = xlDelimited

            .Refresh BackgroundQuery:=False

        End With

        

        ' Update the row counter after importing CSV

        RLr = ReportSheet.Cells(ReportSheet.Rows.Count, "B").End(xlUp).Row

        ' Insert the file name in column A for the imported rows

        ReportSheet.Cells(RLr - 1, "A").Resize(RLr).Value = ReferFileName

        ReferFileName = Dir ' Get the next file

    Loop

    

    ReportSheet.Range("A1").Value = "File Name"

    ReportBook.Save

    Application.ScreenUpdating = True

    

    MsgBox "CSV Files Merged Successfully", vbInformation

End Sub

Private Sub btnClose_Click()

    Unload Me ' This will close the UserForm

End Sub

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

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

Download file

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

Excel Combo (Tips & Tricks)

=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")

Example in N2

There is a bee in a house above the wall

Total "e" count

=LEN(N2) - LEN(SUBSTITUTE(N2, "e", ""))

Total words in a sentence

=LEN(TRIM(N2)) - LEN(SUBSTITUTE(TRIM(N2), " ", "")) + 1

Prevent Duplicate Entry in Cells

Sum in perticular field wihout sumif (Use Ctrl+Shift+Enter)

=SUM((A2:A29="East") * B2:B29)

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")

Sumif in range

=SUMIF(A2:A5,"*red*",B2:B5)

Example in N2 (There is a bee in a house above the wall)

=LEN(N2) - LEN(SUBSTITUTE(N2, "e", ""))(Total "e" count)

=LEN(TRIM(N2)) - LEN(SUBSTITUTE(TRIM(N2), " ", "")) + 1 (Total words in a sentence)

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

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

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

=SUM((A2:A29="East") * B2:B29)

=SUMIF(A2:A5,"*red*",B2:B5)

=SUMIF(A2:A10, "January", B2:B10)

=SUMIF(A2:A10, "*red*", B2:B10)

=SUMIF(B2:B10, ">100", B2:B10)

=SUM((A2:A10="January") * B2:B10)

=COUNTIF(A2:A10, "Apple")

=COUNTIF(A2:A10, "*John*")

=COUNTIF(A2:A10, "<>*")

=COUNTIFS(B2:B10, ">=50", B2:B10, "<=100")

=AVERAGEIF(A2:A10, "Electronics", B2:B10)

=AVERAGEIF(B2:B10, ">200", B2:B10)

=AVERAGEIF(A2:A10, "<>*", B2:B10)

=SUM(IF(MOD(ROW(A2:A10),2)=0, IF(A2:A10="Red", B2:B10)))

=SUM(LEN(A2:A10) - LEN(SUBSTITUTE(A2:A10, "a", "")))

=SUMIF(A2:A10, REPT("?", MAX(LEN(A2:A10))), B2:B10)

=SUM(IF(MOD(ROW(B2:B10)-ROW(B2)+1,3)=0, B2:B10))

=SUM(1/COUNTIF(A2:A10, A2:A10)) (Ctrl + Shift + Enter)

=SUM(OFFSET(B1, COUNTA(B:B)-5, 0, 5, 1))

Download File

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

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

C1l2i5ck here to Download 

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

AUTO PIVOT MIS 

C1l2i5ck here to Download 

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

STATIC EXL FORMULAS Practice 

C1l2i5ck here to Download               C1l2i5ck here to Download 

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

LOOKUPS PRACTICE 

C1ick here to Download                      C1ick here to Download 

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

Sample Copy from 1sheet to Anotehr sheet

Sub DataCopy()

    Dim ws As Worksheet, ws2 As Worksheet

    Dim LastRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")

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

    ' Add a new sheet

    Set ws2 = ThisWorkbook.Sheets.Add

    ' Copy entire rows from 1 to LastRow

    ws.Rows("1:" & LastRow).Copy

    ws2.Range("A1").PasteSpecial xlPasteValues

    Application.CutCopyMode = False

End Sub

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

Sample Hyperlink on Userform and System button

Private Sub CommandButton1_Click()

    ' Execute the msinfo32 command to open System Information

    Shell "msinfo32", vbNormalFocus

End Sub

Private Sub Label1_Click()

    Dim hyperlink As String

    hyperlink = "https://zee-yan.blogspot.com/" ' Replace with your URL

    ThisWorkbook.FollowHyperlink hyperlink

End Sub

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

Meter, Guage animated images

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

VBA Nevigation to links excel IE

Sub NavigateAndClickLinks()
    Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    
    ' Open IE and make it visible
    IE.Visible = True
    
    ' Navigate to the first page
    IE.Navigate "https://zee-yan.blogspot.com/"
    
    ' Wait until the first page is fully loaded
    Do While IE.Busy Or IE.ReadyState <> 4
        DoEvents
    Loop
    
    ' Now, navigate to the Tips n Tricks page
    IE.Navigate "https://zee-yan.blogspot.com/p/tips-n-tricks.html"
    
    ' Wait until the page is fully loaded
    Do While IE.Busy Or IE.ReadyState <> 4
        DoEvents
    Loop
    
    ' Now, find and click the link with text "Download file" (Google Drive link)
    Dim link As Object
    Set link = Nothing
    
    ' Search for the link with the text "Download file"
    For Each link In IE.document.getElementsByTagName("a")
        If link.innerText = "Download file" Then
            link.Click
            Exit For
        End If
    Next link
    
    ' Wait for Google Drive link to open
    Do While IE.Busy Or IE.ReadyState <> 4
        DoEvents
    Loop
    
    ' Notify user that the process is complete
    MsgBox "Download page opened!"
    
    ' Clean up
    Set IE = Nothing
End Sub