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
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
***********************************************************************************
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
***********************************************************************************
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.
***********************************************************************************
***********************************************************************************
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(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))
**************************************************************************************************************
***********************************************************************************
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)
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)
******************************************************************************************
VBA for Macro(Professional)
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
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
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
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
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
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
*********************************************************************
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
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
**********************************************************************************
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
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
*********************************************************************************
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
*******************************************************************
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
*******************************************************************
*******************************************************************
*******************************************************************
AUTO PIVOT MIS
*******************************************************************
STATIC EXL FORMULAS Practice
*******************************************************************
LOOKUPS PRACTICE
*******************************************************************
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
*******************************************************************
Button Click Open Html File
Private Sub CommandButton1_Click()
Dim FilePath As String
FilePath = "C:\Users\Local\Desktop\Books\FlowChart.htm"
If Dir(FilePath) <> "" Then
' Use Windows Explorer to open the file
Shell "explorer.exe """ & FilePath & """", vbNormalFocus
Else
MsgBox "Could not open the file. Please check the file path or file name.", vbExclamation
End If
End Sub
*******************************************************************
Hide/Show Excel while opening and Rdio btn
Private Sub UserForm_Initialize()
' Hide Excel application window
Application.Visible = False
' Default to "Hide" option selected
OptionButtonHide.Value = True
End Sub
Private Sub OptionButtonShow_Click()
If OptionButtonShow.Value = True Then
Application.Visible = True
End If
End Sub
Private Sub OptionButtonHide_Click()
If OptionButtonHide.Value = True Then
Application.Visible = False
End If
End Sub
'This code in Workbook DoubleClick
Private Sub Workbook_Open()
UserForm1.Show
Application.Visible = False
End Sub
'Optional to Completly Close excel
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If Not Application.Visible Then
ThisWorkbook.Save
Application.Quit
End If
End Sub
*******************************************************************
INTR CODE
Private Sub CommandButton1_Click()
Dim fd As FileDialog
Dim fileItem As Variant
Dim wbMain As Workbook, wbData As Workbook
Dim wsMain As Worksheet, wsData As Worksheet, wsFilter As Worksheet
Dim lastRowMain As Long, lastRowData As Long, lastColData As Long
Dim rngToCopy As Range
Dim totalFiles As Integer
Dim currentFile As Integer
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim tempWB As Workbook
Dim rngMail As Range
Dim inspector As Object
Dim wordEditor As Object
Set wbMain = ThisWorkbook
Set wsMain = wbMain.Sheets("Sheet1")
' Create File Dialog to select multiple Excel files
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select Excel Files"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If .Show <> -1 Then Exit Sub ' Exit if no file selected
End With
totalFiles = fd.SelectedItems.Count
If totalFiles = 0 Then Exit Sub
' Initialize ProgressBar
With Me.ProgressBar1
.Min = 0
.Max = totalFiles
.Value = 0
End With
Application.ScreenUpdating = False
currentFile = 0
For Each fileItem In fd.SelectedItems
currentFile = currentFile + 1
Set wbData = Workbooks.Open(fileItem)
Set wsData = wbData.Sheets(1) ' Assuming data is in first sheet
' Apply AutoFilter on row 1 (headers)
If Not wsData.AutoFilterMode Then
wsData.Rows(1).AutoFilter
End If
' Filter column D (4) to exclude blanks in "Date"
wsData.Rows(1).AutoFilter Field:=4, Criteria1:="<>"
' Get last row with data in column A
lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
' Get last column with data in row 1
lastColData = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
On Error Resume Next
' Dynamically define range from A2 to last used cell
Set rngToCopy = wsData.Range(wsData.Cells(2, 1), wsData.Cells(lastRowData, lastColData)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngToCopy Is Nothing Then
' Find next available row in Mainfile Sheet1 column B
lastRowMain = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row + 1
If lastRowMain < 2 Then lastRowMain = 2 ' Ensure it starts from B2
' Copy the filtered range and paste values only
rngToCopy.Copy
wsMain.Cells(lastRowMain, "B").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
wbData.Close SaveChanges:=False
Set rngToCopy = Nothing
' Update ProgressBar
Me.ProgressBar1.Value = currentFile
DoEvents ' Allow the UI to refresh
Next fileItem
' === Post-processing: Filter Sheet2 based on CheckBox1 ===
Set wsFilter = wbMain.Sheets("Sheet2")
' Ensure AutoFilter is enabled on row 1
If Not wsFilter.AutoFilterMode Then
wsFilter.Rows(1).AutoFilter
End If
' Column G is column 7
If Me.CheckBox1.Value = True Then
' Apply filter to show values less than 100
wsFilter.Rows(1).AutoFilter Field:=7, Criteria1:="<100"
Else
' Clear filter for column G only (keep others intact)
wsFilter.Rows(1).AutoFilter Field:=7
End If
' === Copy Filtered Data from Sheet2 ===
On Error Resume Next
If wsFilter.AutoFilterMode And wsFilter.FilterMode Then
' Get filtered (visible) data
Set rngMail = wsFilter.UsedRange.SpecialCells(xlCellTypeVisible)
Else
' Get all data if no filter
Set rngMail = wsFilter.UsedRange
End If
On Error GoTo 0
If rngMail Is Nothing Then
MsgBox "No data to email!", vbExclamation
Exit Sub
End If
' Copy the data to a temporary workbook to preserve formatting
rngMail.Copy
Set tempWB = Workbooks.Add
With tempWB.Sheets(1)
.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.UsedRange.Columns.AutoFit
End With
' === Create Outlook Email ===
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = "ritesh.gawali@syntelligence.in;mayuri.raypalle@syntelligence.in"
.CC = "sanjana.shrivastava@rudramfinance.com; leon.honda@rudramfinance.com; punedialers"
.Subject = "Filtered Report from Mainfile"
.Display ' Show the email before sending
' Copy the formatted range as an HTML table
tempWB.Sheets(1).UsedRange.Copy
' Move focus to the email body and paste
Set inspector = .GetInspector
Set wordEditor = inspector.wordEditor
wordEditor.Application.Selection.TypeText "Hi Team," & vbNewLine & "PFA" & vbNewLine & vbNewLine
wordEditor.Application.Selection.PasteAndFormat (1) ' 1 = wdFormatOriginalFormatting
wordEditor.Application.Selection.TypeText vbNewLine & vbNewLine & "Thanks & Regards," & vbNewLine & "Gyan"
End With
' Close the temporary workbook without saving
Application.CutCopyMode = False
tempWB.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Data imported successfully and email created!", vbInformation
End Sub
Private Sub UserForm_Click()
End Sub
*******************************************************************
INTR CODE (Modulus)
🔹 Module 1: File Selection and Progress Bar Initialization
Sub SelectFilesAndInitializeProgress(ByRef fd As FileDialog, ByRef totalFiles As Integer)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select Excel Files"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If .Show <> -1 Then
totalFiles = 0
Exit Sub
End If
totalFiles = .SelectedItems.Count
End With
With UserForm1.ProgressBar1
.Min = 0
.Max = totalFiles
.Value = 0
End With
End Sub
🔹 Module 2: Process and Import Data from Each Workbook
Sub ImportFilteredData(fd As FileDialog, totalFiles As Integer, wsMain As Worksheet)
Dim fileItem As Variant, currentFile As Integer
Dim wbData As Workbook, wsData As Worksheet
Dim lastRowData As Long, lastColData As Long, lastRowMain As Long
Dim rngToCopy As Range
currentFile = 0
For Each fileItem In fd.SelectedItems
currentFile = currentFile + 1
Set wbData = Workbooks.Open(fileItem)
Set wsData = wbData.Sheets(1)
If Not wsData.AutoFilterMode Then wsData.Rows(1).AutoFilter
wsData.Rows(1).AutoFilter Field:=4, Criteria1:="<>"
lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
lastColData = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set rngToCopy = wsData.Range(wsData.Cells(2, 1), wsData.Cells(lastRowData, lastColData)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngToCopy Is Nothing Then
lastRowMain = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row + 1
If lastRowMain < 2 Then lastRowMain = 2
rngToCopy.Copy
wsMain.Cells(lastRowMain, "B").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
wbData.Close SaveChanges:=False
Set rngToCopy = Nothing
UserForm1.ProgressBar1.Value = currentFile
DoEvents
Next fileItem
End Sub
🔹 Module 3: Filter Sheet2 Based on Checkbox
Sub ApplySheet2Filter(wsFilter As Worksheet, filterByCheckBox As Boolean)
If Not wsFilter.AutoFilterMode Then
wsFilter.Rows(1).AutoFilter
End If
If filterByCheckBox Then
wsFilter.Rows(1).AutoFilter Field:=7, Criteria1:="<100"
Else
wsFilter.Rows(1).AutoFilter Field:=7
End If
End Sub
🔹 Module 4: Create Temp Workbook and Extract Visible Range
Function CopyFilteredDataToTempWorkbook(wsFilter As Worksheet) As Workbook
Dim rngMail As Range
Dim tempWB As Workbook
On Error Resume Next
If wsFilter.AutoFilterMode And wsFilter.FilterMode Then
Set rngMail = wsFilter.UsedRange.SpecialCells(xlCellTypeVisible)
Else
Set rngMail = wsFilter.UsedRange
End If
On Error GoTo 0
If rngMail Is Nothing Then
MsgBox "No data to email!", vbExclamation
Set CopyFilteredDataToTempWorkbook = Nothing
Exit Function
End If
rngMail.Copy
Set tempWB = Workbooks.Add
With tempWB.Sheets(1)
.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.UsedRange.Columns.AutoFit
End With
Set CopyFilteredDataToTempWorkbook = tempWB
End Function
Sub ComposeAndSendEmail(tempWB As Workbook)
Dim OutlookApp As Object, OutlookMail As Object
Dim inspector As Object, wordEditor As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = "ritesh.gawali@syntelligence.in;mayuri.raypalle@syntelligence.in;ramendra.deshpande@syntelligence.in;ravi.bolchatwar@syntelligence.in;ritesh.gawali@syntelligence.in;shivani.jena@syntelligence.in;shraddha.jadhav@syntelligence.in;vaishnavi.kadam@syntelligence.in;vishal.chaugule@syntelligence.in;mangesh.birajdar@syntelligence.in;manmath.chandapure@syntelligence.in;dinkar.shinde@syntelligence.in"
.CC = "sanjana.shrivastava@rudramfinance.com; leon.honda@rudramfinance.com; punedialers"
.Subject = "Filtered Report from Mainfile"
.Display
tempWB.Sheets(1).UsedRange.Copy
Set inspector = .GetInspector
Set wordEditor = inspector.wordEditor
wordEditor.Application.Selection.TypeText "Hi Team," & vbNewLine & "PFA" & vbNewLine & vbNewLine
wordEditor.Application.Selection.PasteAndFormat (1)
wordEditor.Application.Selection.TypeText vbNewLine & vbNewLine & "Thanks & Regards," & vbNewLine & "Gyan"
End With
tempWB.Close SaveChanges:=False
Application.CutCopyMode = False
End Sub
🔹 Module 5: Compose and Display Outlook Email
Sub ComposeAndSendEmailFinal(tempWB As Workbook)
Dim OutlookApp As Object, OutlookMail As Object
Dim inspector As Object, wordEditor As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = "ritesh.gawali@syntelligence.in;mayuri.raypalle@syntelligence.in;ramendra.deshpande@syntelligence.in;ravi.bolchatwar@syntelligence.in;ritesh.gawali@syntelligence.in;shivani.jena@syntelligence.in;shraddha.jadhav@syntelligence.in;vaishnavi.kadam@syntelligence.in;vishal.chaugule@syntelligence.in;mangesh.birajdar@syntelligence.in;manmath.chandapure@syntelligence.in;dinkar.shinde@syntelligence.in"
.CC = "sanjana.shrivastava@rudramfinance.com; leon.honda@rudramfinance.com; punedialers"
.Subject = "Filtered Report from Mainfile"
.Display
tempWB.Sheets(1).UsedRange.Copy
Set inspector = .GetInspector
Set wordEditor = inspector.wordEditor
wordEditor.Application.Selection.TypeText "Hi Team," & vbNewLine & "PFA" & vbNewLine & vbNewLine
wordEditor.Application.Selection.PasteAndFormat (1)
wordEditor.Application.Selection.TypeText vbNewLine & vbNewLine & "Thanks & Regards," & vbNewLine & "Gyan"
End With
tempWB.Close SaveChanges:=False
Application.CutCopyMode = False
End Sub
🔹 Main Control Procedure (Calls the Modules)
Private Sub CommandButton1_Click()
Dim fd As FileDialog
Dim totalFiles As Integer
Dim wbMain As Workbook
Dim wsMain As Worksheet, wsFilter As Worksheet
Dim tempWB As Workbook
Set wbMain = ThisWorkbook
Set wsMain = wbMain.Sheets("Sheet1")
Set wsFilter = wbMain.Sheets("Sheet2")
' Proper call after fd is set and totalFiles retrieved
Call SelectFilesAndInitializeProgress(fd, totalFiles)
If totalFiles = 0 Then Exit Sub
Call ImportFilteredData(fd, totalFiles, wsMain)
Call ApplySheet2Filter(wsFilter, Me.CheckBox1.Value)
Set tempWB = CopyFilteredDataToTempWorkbook(wsFilter)
If tempWB Is Nothing Then Exit Sub
Call ComposeAndSendEmailFinal(tempWB)
'Call ComposeAndSendEmail(tempWB)
'ComposeAndSendEmailFINAL(tempWB As Workbook)
Application.ScreenUpdating = True
MsgBox "Data imported successfully and email created!", vbInformation
End Sub
*******************************************************************
Filtered Deletion
Sub DeleteNAFilteredRows()
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Apply filter to Column A
ws.Range("A1").AutoFilter Field:=1, Criteria1:="#N/A"
' Delete visible rows except header
On Error Resume Next
ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
' Remove filter
ws.AutoFilterMode = False
End Sub
Two Criteria
Two Criteria
Sub DeleteNAandEnquiryRows()
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Turn on AutoFilter with both criteria:
With ws.Range("A1:CV" & lastRow)
.AutoFilter Field:=1, Criteria1:="#N/A" ' Column A
.AutoFilter Field:=6, Criteria1:="Enquiry" ' Column F (6th column)
End With
' Delete all visible rows except the header
On Error Resume Next
ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
' Clear filters
ws.AutoFilterMode = False
End Sub
*******************************************************************
IB Effi
Private Sub CommandButton1_Click()
Dim fd As FileDialog
Dim ReportFile As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim filePath As Variant
Dim rngToCopy As Range
Dim lastRowSource As Long, lastRowDest As Long
Dim lastRowExisting As Long
' Reference to MainFile and destination sheet
Set wsDest = ThisWorkbook.Sheets("RAW")
' Clear old data but keep Row 2 (formulas)
With wsDest
lastRowExisting = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRowExisting > 2 Then
.Range("A3:CO" & lastRowExisting).Delete xlShiftUp
End If
End With
' File picker dialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select Excel Report Files"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
.AllowMultiSelect = True
If .Show = True Then
lastRowDest = 2
For Each filePath In .SelectedItems
Set ReportFile = Workbooks.Open(filePath, ReadOnly:=True)
Set wsSource = ReportFile.Sheets(1)
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
If lastRowSource >= 2 Then
Set rngToCopy = wsSource.Range("A2:CO" & lastRowSource)
rngToCopy.Copy wsDest.Cells(lastRowDest, "A")
lastRowDest = lastRowDest + rngToCopy.Rows.Count
End If
ReportFile.Close SaveChanges:=False
Next filePath
' ? Refresh all pivot tables
RefreshPivotTables
' ? Send Outlook emails with pivot table images
SendPivotEmails
MsgBox "Data import and emails completed.", vbInformation
Else
MsgBox "No files selected.", vbExclamation
End If
End With
End Sub
Private Sub RefreshPivotTables()
Dim ws As Worksheet
Dim pt As PivotTable
Dim pivotSheets As Variant
Dim i As Long
pivotSheets = Array("BRANCHWISE", "STATEWISE", "ENTITY TYPE", "LOAN TYPE")
For i = LBound(pivotSheets) To UBound(pivotSheets)
Set ws = ThisWorkbook.Sheets(pivotSheets(i))
For Each pt In ws.PivotTables
pt.RefreshTable
Next pt
Next i
End Sub
Private Sub SendPivotEmails()
Dim outlookApp As Outlook.Application
Dim mailItem As Outlook.mailItem
Dim ws As Worksheet
Dim pivotSheets As Variant
Dim i As Long
Dim rng As Range
Set outlookApp = New Outlook.Application
pivotSheets = Array("BRANCHWISE", "STATEWISE", "ENTITY TYPE", "LOAN TYPE")
For i = LBound(pivotSheets) To UBound(pivotSheets)
Set ws = ThisWorkbook.Sheets(pivotSheets(i))
Set rng = ws.Range("A3").CurrentRegion
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set mailItem = outlookApp.CreateItem(olMailItem)
With mailItem
.To = "sanjana.shrivastava@rudramfinance.com"
.CC = ""
.Subject = "IB Efficiency - " & pivotSheets(i)
.HTMLBody = "Hi All,<br><br>" & _
"PFA<br><br>" & _
"<img src='cid:PivotImage'><br><br>" & _
"Thanks,<br>Gyan"
' Paste image into body using WordEditor
.Display ' Required to access WordEditor
With .GetInspector.WordEditor
.Application.Selection.Paste
End With
End With
Next i
End Sub
*******************************************************************
Intra Dwn
https://limewire.com/d/xKkW5#pQM4qiEcZw
Code
Private Sub CommandButton1_Click()
Dim fd As FileDialog
Dim ReportFile As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim filePath As Variant
Dim rngToCopy As Range
Dim lastRowSource As Long, lastRowDest As Long
Dim lastRowExisting As Long
Dim area As Range, rowRng As Range
Dim i As Long
' Reference to Main_data sheet
Set wsDest = ThisWorkbook.Sheets("Main_data")
Application.ScreenUpdating = False
' Clear old data but keep Row 2 (formulas)
With wsDest
lastRowExisting = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRowExisting > 2 Then
.Range("B3:AM" & lastRowExisting).Delete xlShiftUp
End If
End With
' File picker dialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select Excel Report Files"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
.AllowMultiSelect = True
If .Show = True Then
lastRowDest = 2
For Each filePath In .SelectedItems
Set ReportFile = Workbooks.Open(filePath, ReadOnly:=True)
Set wsSource = ReportFile.Sheets(1)
If Not wsSource.AutoFilterMode Then wsSource.Rows(9).AutoFilter
wsSource.Rows(9).AutoFilter Field:=3, Criteria1:="<>"
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Set rngToCopy = wsSource.Range("B10:AM" & lastRowSource).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngToCopy Is Nothing Then
For Each area In rngToCopy.Areas
For Each rowRng In area.Rows
wsDest.Range("B" & lastRowDest).Resize(1, rowRng.Columns.Count).Value = rowRng.Value
lastRowDest = lastRowDest + 1
Next rowRng
Next area
End If
ReportFile.Close SaveChanges:=False
Set rngToCopy = Nothing
Next filePath
' Delete rows with #N/A in column A
With wsDest
lastRowExisting = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastRowExisting To 2 Step -1
If IsError(.Cells(i, "A").Value) Then
If .Cells(i, "A").Text = "#N/A" Then .Rows(i).Delete
End If
Next i
End With
' Delete rows with "Manual 3" in column B
With wsDest
lastRowExisting = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = lastRowExisting To 2 Step -1
If InStr(1, .Cells(i, "B").Value, "Manual 3", vbTextCompare) > 0 Then
.Rows(i).Delete
End If
Next i
End With
' === Apply filters in Call wise performance ===
Dim wsCall As Worksheet
Dim lastRowCall As Long
Dim rngFilter As Range
Dim rngVisible As Range
Set wsCall = ThisWorkbook.Sheets("Call wise performance")
lastRowCall = wsCall.Cells(wsCall.Rows.Count, "A").End(xlUp).Row
Set rngFilter = wsCall.Range("A2:K" & lastRowCall)
If wsCall.AutoFilterMode Then wsCall.AutoFilterMode = False
rngFilter.AutoFilter
' Apply Productive filter: exclude both 0 (number), "0" (text), and "-"
If UserForm1.CheckBoxProductive.Value = True Then
wsCall.Range("D3:D" & lastRowCall).Replace What:=0, Replacement:="0", LookAt:=xlWhole
rngFilter.AutoFilter Field:=4, Criteria1:="<>0"
rngFilter.AutoFilter Field:=4, Criteria1:="<>-", Operator:=xlAnd
End If
' Apply Idle filter: less than 100
If UserForm1.CheckBoxIdle.Value = True Then
rngFilter.AutoFilter Field:=5, Criteria1:="<100"
End If
' Copy filtered visible data
On Error Resume Next
Set rngVisible = rngFilter.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVisible Is Nothing Then
MsgBox "No visible data after filtering in Call wise performance sheet.", vbExclamation
GoTo Cleanup
End If
' Compose Outlook email
Dim olApp As Object, olMail As Object
Dim dataHTML As String
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
' Convert visible range to HTML
rngVisible.Copy
dataHTML = RangetoHTML(rngVisible)
With olMail
.To = "ravi.more@credence.com"
.CC = "iraishita.arvindakshan@credence.com"
.SentOnBehalfOfName = "Dialer@credence.com"
.Subject = "Intraday Report"
.HTMLBody = "<p>Hi all,</p><p>PFB the intraday snapshot:</p>" & dataHTML & "<br><br>Regards,<br>Your Name"
.Display
End With
Cleanup:
MsgBox "Data import, filter, and email completed.", vbInformation
Else
MsgBox "No files selected.", vbExclamation
End If
End With
Application.ScreenUpdating = True
End Sub
' --- Helper Function to convert Range to HTML for email ---
Function RangetoHTML(rng As Range) As String
Dim fso As Object, ts As Object
Dim TempFile As String, TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
With TempWB.PublishObjects.Add(xlSourceRange, TempFile, TempWB.Sheets(1).Name, _
TempWB.Sheets(1).UsedRange.Address, xlHtmlStatic)
.Publish True
End With
TempWB.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Kill TempFile
End Function
No comments:
Post a Comment