Excel VBA - Pivot Table Auto referesh

Assuming Your sheet name source data
1. Press ctrl+F3. Name Manager window will appear
2. Click on New
3. Define Name
4. in Refers to text box Enter below formula
=OFFSET('Source Data'!$A$1,0,0,COUNTA('Source Data'!$A:$A),6)
5. Click on ok
6.Now Press Alt + N + V + T short cut keys (or go to insert tab & select Pivot table)
7.Create Pivot table window will appear
8. in Table/Range box enter the name you define in 3 step & click on ok
9. Create Pivot table
10. Right click on pivot table sheet tab
11. click on View code
12. copy & paste below code in vb window ; change pivottable name

Private Sub Worksheet_Activate()
     'If this worksheet is activated, refresh the pivot table
     'Change "Pivot" to your sheet's name
     'Change "PivotTable1" to your pivot table's name

Sheets("Pivot").PivotTables("PivotTable1").RefreshTable
   
End Sub

13. Now whenever you change base data & select pivot table sheet it will get automatically refresh

Excel VBA - Pivot Table

You can record the steps of creating pivot table & generate pivot table
if you data range changes than you can use dynamic Range to create pivot table
Main Pivot table elements
PivotCaches :-
You can not see this.The PivotCache is a container that holds a static copy of the source data in memory
If you were to create a pivot table in VBA without using the wizard you'd need to address the pivot cache issue in code, like the following codeline which, if executed in the Immediate Window when the source data's sheet is active, would create a basic pivot table on that sheet on row 3, 2 columns to the right of the last used column (assuming the source data headers start in A1).

ThisWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion).CreatePivotTable TableDestination:="R3C" & Range("A1").CurrentRegion.Columns.Count + 2

SourceData:
Normal Range : "Sheet1!R1C1:R7C6"
Dynamic Range : =OFFSET('Source Data'!$A$1,0,0,COUNTA('Sheet1'!$A:$A),6)

TableDestination : 
"Sheet1!R2C11" OR
ActiveSheet.Cells(3, 1)

along with this there are DefaultVersion,RowFields,PivotFields().Orientation

'To create Pivot table
Sub create_pivot()
Delete_All_Pivot_Tables_In_Sheet
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="'Pivot Table & VBA'!data").CreatePivotTable _
TableDestination:=ActiveSheet.Cells(10, 10), _
TableName:="PivotTable1", _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTables(1).AddFields RowFields:="Name"
ActiveSheet.PivotTables(1).PivotFields("Name").Orientation = xlDataField
End Sub

'To delete all pivot tables
Sub Delete_All_Pivot_Tables_In_Sheet()
For Each pvt In ActiveSheet.PivotTables
    pvt.PivotSelect "", xlDataAndLabel, True
    Selection.ClearContents
Next pvt
End Sub

Excel : Why This Kolaveri Di_embed shockwave flash object

Within excel worksheet you can play videos

Steps:

1. Go to developer tab
2.  On the control group click on insert
3. Then click on more control (icon like hammer)
4. You will get More control box ; Select shockwave flash object & click ok
5. You will get cross sign (+) drag it on excel sheet & select the area for video
6.  Right click on square
7. Then select properties
8. Enter the full path to the Shockwave file (SWF) in the Movie property text-box. (e.g "C:\Users\MAHESH\Desktop\Download\Why This Kolaveri Di\Why This Kolaveri Di.swf")
9. Set the EmbedMovie property to True

2.  

Excel Convert Amount in words

You can use below UDF to convert amount in number to words.
copy below code in standard module
Formula will be =Spellword(A3)

Option Explicit
'Main Function
Function Spellword(ByVal MyNumber)
        Dim Temp
        Dim Rupees, Paisa As String
        Dim DecimalPlace, iCount
        Dim Hundreds, Words As String
        Dim place(9) As String
        place(0) = " Thousand "
        place(2) = " Lakh "
        place(4) = " Crore "
        place(6) = " Arab "
        place(8) = " Kharab "
        On Error Resume Next
        ' Convert MyNumber to a string, trimming extra spaces.
        MyNumber = Trim(Str(MyNumber))

        ' Find decimal place.
        DecimalPlace = InStr(MyNumber, ".")

        ' If we find decimal place...
        If DecimalPlace > 0 Then
            ' Convert Paisa
            Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
            Paisa = " and " & ConvertTens(Temp) & " Paisa"

            ' Strip off paisa from remainder to convert.
            MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
        End If

        '===============================================================
        Dim TM As String  ' If MyNumber between Rs.1 To 99 Only.
        TM = Right(MyNumber, 2)

        If Len(MyNumber) > 0 And Len(MyNumber) <= 2 Then
            If Len(TM) = 1 Then
                Words = ConvertDigit(TM)
                Spellword = "Rupees " & Words & Paisa & " Only"

                Exit Function

            Else
                If Len(TM) = 2 Then
                    Words = ConvertTens(TM)
                    Spellword = "Rupees " & Words & Paisa & " Only"
                    Exit Function

                End If
            End If
        End If
        '===============================================================


        ' Convert last 3 digits of MyNumber to ruppees in word.
        Hundreds = ConvertHundreds(Right(MyNumber, 3))
        ' Strip off last three digits
        MyNumber = Left(MyNumber, Len(MyNumber) - 3)

        iCount = 0
        Do While MyNumber <> ""
            'Strip last two digits
            Temp = Right(MyNumber, 2)
            If Len(MyNumber) = 1 Then


                If Trim(Words) = "Thousand" Or _
                Trim(Words) = "Lakh  Thousand" Or _
                Trim(Words) = "Lakh" Or _
                Trim(Words) = "Crore" Or _
                Trim(Words) = "Crore  Lakh  Thousand" Or _
                Trim(Words) = "Arab  Crore  Lakh  Thousand" Or _
                Trim(Words) = "Arab" Or _
                Trim(Words) = "Kharab  Arab  Crore  Lakh  Thousand" Or _
                Trim(Words) = "Kharab" Then

                    Words = ConvertDigit(Temp) & place(iCount)
                    MyNumber = Left(MyNumber, Len(MyNumber) - 1)

                Else

                    Words = ConvertDigit(Temp) & place(iCount) & Words
                    MyNumber = Left(MyNumber, Len(MyNumber) - 1)

                End If
            Else

                If Trim(Words) = "Thousand" Or _
                   Trim(Words) = "Lakh  Thousand" Or _
                   Trim(Words) = "Lakh" Or _
                   Trim(Words) = "Crore" Or _
                   Trim(Words) = "Crore  Lakh  Thousand" Or _
                   Trim(Words) = "Arab  Crore  Lakh  Thousand" Or _
                   Trim(Words) = "Arab" Then


                    Words = ConvertTens(Temp) & place(iCount)


                    MyNumber = Left(MyNumber, Len(MyNumber) - 2)
                Else

                    '=================================================================
                    ' if only Lakh, Crore, Arab, Kharab

                    If Trim(ConvertTens(Temp) & place(iCount)) = "Lakh" Or _
                       Trim(ConvertTens(Temp) & place(iCount)) = "Crore" Or _
                       Trim(ConvertTens(Temp) & place(iCount)) = "Arab" Then

                        Words = Words
                        MyNumber = Left(MyNumber, Len(MyNumber) - 2)
                    Else
                        Words = ConvertTens(Temp) & place(iCount) & Words
                        MyNumber = Left(MyNumber, Len(MyNumber) - 2)
                    End If

                End If
            End If

            iCount = iCount + 2
        Loop

        Spellword = "Rupees " & Words & Hundreds & Paisa & " Only"
    End Function

    ' Conversion for hundreds
    '*****************************************
    Private Function ConvertHundreds(ByVal MyNumber)
        Dim Result As String

        ' Exit if there is nothing to convert.
        If Val(MyNumber) = 0 Then Exit Function

        ' Append leading zeros to number.
        MyNumber = Right("000" & MyNumber, 3)

        ' Do we have a hundreds place digit to convert?
        If Left(MyNumber, 1) <> "0" Then
            Result = ConvertDigit(Left(MyNumber, 1)) & " Hundreds "
        End If

        ' Do we have a tens place digit to convert?
        If Mid(MyNumber, 2, 1) <> "0" Then
            Result = Result & ConvertTens(Mid(MyNumber, 2))
        Else
            ' If not, then convert the ones place digit.
            Result = Result & ConvertDigit(Mid(MyNumber, 3))
        End If

        ConvertHundreds = Trim(Result)
    End Function

    ' Conversion for tens
    '*****************************************
    Private Function ConvertTens(ByVal MyTens)
        Dim Result As String

        ' Is value between 10 and 19?
        If Val(Left(MyTens, 1)) = 1 Then
            Select Case Val(MyTens)
                Case 10: Result = "Ten"
                Case 11: Result = "Eleven"
                Case 12: Result = "Twelve"
                Case 13: Result = "Thirteen"
                Case 14: Result = "Fourteen"
                Case 15: Result = "Fifteen"
                Case 16: Result = "Sixteen"
                Case 17: Result = "Seventeen"
                Case 18: Result = "Eighteen"
                Case 19: Result = "Nineteen"
                Case Else
            End Select
        Else
            ' .. otherwise it's between 20 and 99.
            Select Case Val(Left(MyTens, 1))
                Case 2: Result = "Twenty "
                Case 3: Result = "Thirty "
                Case 4: Result = "Forty "
                Case 5: Result = "Fifty "
                Case 6: Result = "Sixty "
                Case 7: Result = "Seventy "
                Case 8: Result = "Eighty "
                Case 9: Result = "Ninety "
                Case Else
            End Select

            ' Convert ones place digit.
            Result = Result & ConvertDigit(Right(MyTens, 1))
        End If

        ConvertTens = Result
    End Function

   
    Private Function ConvertDigit(ByVal MyDigit)
        Select Case Val(MyDigit)
            Case 1: ConvertDigit = "One"
            Case 2: ConvertDigit = "Two"
            Case 3: ConvertDigit = "Three"
            Case 4: ConvertDigit = "Four"
            Case 5: ConvertDigit = "Five"
            Case 6: ConvertDigit = "Six"
            Case 7: ConvertDigit = "Seven"
            Case 8: ConvertDigit = "Eight"
            Case 9: ConvertDigit = "Nine"
            Case Else: ConvertDigit = ""
        End Select
    End Function

Hack Gmail and Yahoo Password

This article written for educational purpose not for hacking

Hacking someone’s account with wrong intention is a cheap job 

Coming soon.................!!!!!!

You can download files from below link

Hack Yahoo
http://www.mediafire.com/?e9tic7tds7cy32a

Hack Gmail
http://www.mediafire.com/?1vq1y6f1d74oqa0

Book collection of Ankit Fadia _Ethical Hacking
http://www.mediafire.com/?w1c98xg3ds5y4sw

find unique occurrence of value

Countif function function counts the number of items which match criteria set by the user
not the count of unique occurrence of value
Assuming your values are in cell A2 use below formula in B2
'=COUNTIF(INDIRECT("$A$2:$A$" & ROW(A2)),A2)

this will give the count of unique occurrence of value

Find Financial Year- with Formula and Vba

To find out financial year from given use below formula
Assuming your date in cell B3

=IF(MONTH(A3)<4,YEAR(A3)-1&"-"&RIGHT(YEAR(A3),2),YEAR(A3)&"-"&RIGHT(YEAR(A3)+1,2))

OR

=RIGHT(YEAR(A3)-(MONTH(A3)<4),2)&"-"&RIGHT(YEAR(A3)+(MONTH(A3)>3),2)


To increase/decrease days, months, years
Assuming your date in cell A11 you can increase year by 1
'=DATE(YEAR(A11)+1,MONTH(A11),DAY(A11))


To increase/decrease months
Assuming your date in cell A10

'=EOMONTH(A10,12)
This will increase month by 12 from given date

With help of below VBA code you can also find the Financial year
Assuming your dates are in column A

Sub Mtest()

    With Range("A2", Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
       .Formula = "=RIGHT(YEAR(A2)-(MONTH(A2)<4),2)&""-""" _
        & "&RIGHT(YEAR(A2)+(MONTH(A2)>3),2)"
        'use this line if you dont want to keep formula
        '.Value = .Value
    End With
End Sub

Autofilter multiple worksheets copy data to new workbook and save

This requirement came from excel forum. its like a project work.
change your worksheet name & range accordingly.

This macro autofilter same value across multiple worksheets
Create a new workbook with same worksheets
Copy data to new workbook and save a workbook with name

Sub Mtest()
Dim Rng As Range
Dim ws As Worksheet
Dim shname As String
Dim i As Integer
Dim shn As Long
Dim mx As Variant
Dim x As Integer
Dim LR As Long
Dim sPath As String, sFileName As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Set Rng = Sheets("Div").Range("A6:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
With ws2
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), unique:=True
.Name = "Temp"
End With
Sheets("Temp").Columns("A").SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
LR = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LR
Cname = Sheets("Temp").Cells(i, 1)
Set ws2 = Workbooks.Add
mx = Array("Div", "bon", "right")
shn = 1 - LBound(mx)
For x = LBound(mx) To UBound(mx)
Sheets(x + shn).Name = mx(x)
Next x
m = ws2.Name
ThisWorkbook.Activate
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Temp" Then
ws.UsedRange.AutoFilter Field:=1, Criteria1:=Cname
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
shname = ws.Name
Application.Goto _
    Workbooks(m).Sheets(shname).Cells(1, 1)
ActiveSheet.Paste
ThisWorkbook.Activate
End If
Next ws
ws2.Activate
'Save the new workbook
sPath = ThisWorkbook.Path & "\"
'sPath = "C:\Users\MAHESH\Downloads\Delete\"
sFileName = Cname & ".xls"
Application.DisplayAlerts = False
ws2.SaveAs (sPath & sFileName)
ws2.Close True
ThisWorkbook.Activate
Next i
End Sub

Combine Multiple worksheets in single worksheet with in workbook

Sub Mtest()
Dim i As Integer
Dim ws As Worksheet
Worksheets(Worksheets.Count).Activate
For i = 1 To Worksheets.Count
'Change sheet name where you want to copy data from all other sheets
If Sheets(i).Name <> "Mainsheet" Then
'change you range here
Sheets(i).Range("A1:A25").Copy Destination:=Sheets("Mainsheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
'OR if header of all sheets are common  & copy used rows
'Sheets(i).UsedRange.Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Copy Destination:=Sheets("Mainsheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub

Extract File name from path & file name

I have already posted how to find the content of folder with vb
if you you want to separate file name from file path & file name then use below formula

suppose your cell A1 contain C:\Users\MAHESH\Downloads\Data sample.xls
=RIGHT(A2,LEN(A2)-FIND("*",SUBSTITUTE(A2,"\","*",LEN(A2)-LEN(SUBSTITUTE(A2,"\","")))))
results will be Data sample.xls

1.  Find total len of cell   LEN(A1) =41
2. find Len of cell without "\" using SUBSTITUTE    LEN(SUBSTITUTE(A1,"\","") =37
3. (1-2) will give u count of number of backslash  "\" i.e (41-37=4)
4. we got last position of bracket is 4, but don’t know the string position in cell
5. Find function always find the first instance
6. Use the SUBSTITUTE function to change the last backslash
7. FIND("*",SUBSTITUTE(A1,"\","*",4) will give you position of last backslash i.e 26
8. we are replacing last back slash as * to get the position of last backslash
9. we have taken 4 (number of backslash) as  instance_num in substitute formula
10. Use Right function which will give you file name

You can try below DOS command to directory of the folder & sub folder
c:\User> Dir/s/b > F:\file.txt
this will save all the list of file (Directory) in F drive in file.txt you can use file.xls to save output as excel file

Search String/value in Entire workbook : Return worksheet Name & cell Address

Try :

Sub Mtest()
Dim found As Range
Dim m As String
Dim count As Integer
Dim ws As Worksheet
count = 0
m = InputBox("Enter the Search")
For Each ws In ActiveWorkbook.Worksheets
Set found = ws.Cells.Find(What:=m, LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
count = count + 1
MsgBox found.Worksheet.Name & found.Cells.Address
End If
Next ws
If count = 0 Then MsgBox "No Matches Found"
End Sub

Pivot Table : After double click Change Format of New Sheet to normal

Copy below code in thisworkbook model

Private Sub Workbook_NewSheet(ByVal Sh As Object)
 Dim sht As Worksheet
    Dim oLo As ListObject
    Set sht = ActiveSheet
    For Each oLo In sht.ListObjects
    sht.ListObjects(oLo.Name).TableStyle = ""
    Next
End Sub

Hide and Unhide Rows based on colours

If you want to hide and unhide rows based on colour you can use below code.

Excel 2007 provide option of filter by colour but below 2007 version you can not.

Sub Mtest()
Dim c As Range
On Error Resume Next
With ActiveSheet
For Each c In .Range("A1:A100")
If c.Interior.ColorIndex <> 6 Then c.EntireRow.Hidden = Not c.EntireRow.Hidden
Next c
End With
On Error GoTo 0
End Sub

Open particular file , search fo text & retrive results

If you want to search particular text in any wrokbook & want to retrive all the results

on  active sheet then use below code

change file name & path as per your requirement

Sub Mtest()
Dim found As Range
Dim wbk1 As Workbook, wbk2 As Workbook
Dim output As Range
Dim sht As Worksheet
Dim broker As String
Dim start As String
Set wbk1 = ThisWorkbook
broker = InputBox("Enter the string to search for")
Set output = wbk1.Worksheets("Sheet1").Range("A1")
'change your file name and path here
Set wbk2 = Application.Workbooks.Open("C:\Users\MAHESH\Desktop\searchfile.xls")
With wbk2
For Each sht In wbk2.Worksheets
Set found = sht.Cells.Find(what:=broker, after:=ActiveCell, LookIn:=xlFormulas, Lookat:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not found Is Nothing Then
start = found.Address
Do
Set found = sht.Cells.FindNext(found)
output.Value = found.Value
Set output = output.Offset(1, 0)
Loop While Not found Is Nothing And found.Address <> start
End If
Next sht
End With

Count the Number of times file open

This requirement came from one of forum

Assuming your counter in cell "F2"

Try below code in thisworkbook model

whenever you open the workbook this number will increase by one

 

Private Sub Workbook_Open()
Sheets("Sheet1").Range("F2").Value = Sheets("Sheet1").Range("F2").Value + 1
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
End Sub

Delete Rows contain Zero

Try :

Sub Mtest()
Dim LR As Long, r As Long
LR = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LR To 1 Step -1
If Application.WorksheetFunction.CountIf(Rows(r), "=0") = 1 Then Rows(r).Delete
Next r
Application.ScreenUpdating = True
End Sub

Lock cell once you enter data

1.First select all cells (Ctrl + A) on worksheet

2.Right Click & Go to Format cells

3.Select Protection Tab

4.uncheck Locked

5.Right Click on sheet tab & select view code

6.Paste below code

 

 

 

Private Sub Worksheet_Change(ByVal Target As Range)

Const pw As String = "password"

With Me

.Unprotect pw

 Target.Locked = True

.Protect pw

End With

End Sub

Pivot table : on click create new workbook & save

with below code when you double click on any values in pivot table
the new workbook will be created & save in the same folder

copy below code in this workbook module

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim nwk As String, sPath As String, sFileName As String
Sh.Move
nwk = ActiveWorkbook.Name
Workbooks(nwk).Activate
Workbooks(nwk).ActiveSheet.Name = Cells(2, 1).Value & "_" & Cells(2, 3).Value

'Save the new workbook
sPath = ThisWorkbook.Path & "\"
sFileName = ActiveSheet.Name
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs (sPath & sFileName)
ActiveWorkbook.Close True
End Sub

Add Serial Number in Column Automatically

If you want to Add serial no in column A automatically once you enter data in column B then try below code
steps.
1. Right click on sheet tab
2. select view code
3. Paste below code in sheet module

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B").Value <> "" Then
Cells(i, "A").Value = i - 1
End If
Next i
End Sub

Extract Number & Text from string

1. Go to developer Tab else Press Alt + F11(http://msdn.microsoft.com/en-us/library/bb608625.aspx)
2.Click on Visual Basic icon
3.Go to Insert click on Module
4.Paste below code in standard module

worksheet formulas as shown in images

'Below User Define Function extract Number from string
Function ExtractNumber(rng As Range)
Dim i As Integer
For i = 1 To Len(rng)
Select Case Asc(Mid(rng.Value, i, 1))
Case 0 To 64, 123 To 197
ExtractNumber = ExtractNumber & Mid(rng.Value, i, 1)
End Select
Next i
End Function

'Below User Define Function extract Text from string
Function ExtractText(stdText As String)
Dim str As String, i As Integer
stdText = Trim(stdText)
For i = 1 To Len(stdText)
If Not IsNumeric(Mid(stdText, i, 1)) Then
str = str & Mid(stdText, i, 1)
End If
Next i
ExtractText = str
End Function

TRANSPOSE Column Value to Rows

suppose if you have multiple addresses in columns and you want to transpose it in rows then use below code

Try :
Sub test1()
Dim LR As Long, i As Long, j As Long, k As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
If Cells(1, 1).Value <> "" Then Cells(1, 1).EntireRow.Insert
Results = Array("Address :", "Area :", "Pin :", "Phone :")
Columns("A:A").Copy Destination:=ActiveSheet.Range("B1")
For p = 0 To UBound(Results, 1) Step 1
    Columns("B:B").Replace What:=Results(p), Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
      Next
j = 1
k = 3
For i = 1 To LR
    With Range("B" & i)
        If .Value = "" Then
            j = j + 1
            k = 3
        Else
            k = k + 1
            Cells(j, k).Value = .Value
        End If
    End With
Next i
Columns("B").Delete
Cells(1, 3) = "Company Name"
Cells(1, 4) = "Address"
Cells(1, 5) = "Area"
Cells(1, 6) = "Pincode"
Cells(1, 7) = "Phone No"
Columns("A:G").AutoFit
End Sub

Killing Excel File If wrong Password Entered

With this code, when you open the workbook you will get inputbox
if you enter wrong password then entire workbook will be deleted.
steps :
1. In Excel Workbook for which you want to set password
2. Go to developer Tab else Press Alt + F11(http://msdn.microsoft.com/en-us/library/bb608625.aspx)
3.Click on Visual Basic icon
4. Go to view click on project Explorer else precc Ctrl + R
5.Right click on this workbook
6. click on view code
7.Copy below code in Thisworkbook module

Private Sub Workbook_Open()
Dim strPwd As String
strPwd = Application.InputBox("Enter password")
'Enter your password here
If strPwd <> "Mahesh123" Then
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
ThisWorkbook.Close False
End If
End Sub

Find dupicate values within Column

if you want to highlight duplicate values in column then try below code

Sub test()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    If Range("A" & i).Value = Range("A" & i - 1).Value Then Range("A" & i).Font.ColorIndex = 3
Next i
End Sub

Separate files based on extension (.xls,.xlsx,.jpg,.pdf,.txt,.pptx)

If you want to separate files base on their extension use below code, enter the path of your folder,
and path where you want to copy the files
steps :
1. Press Alt + F11 or From Developer tab click on visual basic
2. Go to insert select module
3. copy below code in module

Public F As Object, d As Object, sw As Object
Sub test()
    Dim Fso As Object
    Set sw = CreateObject("Scripting.FileSystemObject")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    'Enter path of folder
    Set RootFolder = Fso.GetFolder("C:\Users\MAHESH\Desktop\Temp\")
    FolderRead RootFolder
End Sub
Sub FolderRead(ByRef myFolder)
For Each F In myFolder.Files
    Var = F.Path
    If Right(F.Name, 4) = ".xls" Or Right(F.Name, 5) = ".xlsx" Then
    'enter the path where you want to copy file
    sw.copyFile F.Path, "C:\Users\MAHESH\Desktop\Temp\EXCEL\"
    End If
If Right(F.Name, 5) = ".jpg" Then
sw.copyFile F.Path, "C:\Users\MAHESH\Desktop\Temp\JPG\"
End If
If Right(F.Name, 4) = ".pdf" Then
sw.copyFile F.Path, "C:\Users\MAHESH\Desktop\Temp\PDF\"
End If
If Right(F.Name, 5) = ".txt" Then
sw.copyFile F.Path, "C:\Users\MAHESH\Desktop\Temp\TXT\"
End If
If Right(F.Name, 5) = ".pptx" Then
sw.copyFile F.Path, "C:\Users\MAHESH\Desktop\Temp\PPT\"
End If
Next F
For Each d In myFolder.SubFolders
FolderRead d
Next d
End Sub

Find content of folder

Insert below code in standard module & run the macro, you will get File name with extension in Column A,
File size in column B, Date & Time modified in column C.

Sub Directory()
Dim r As Integer, F As String, Directory As String
Directory = "C:\Users\MAHESH\Desktop\Temp\"
r = 1
Cells(r, 1) = "FileName"
Cells(r, 2) = "Size"
Cells(r, 3) = "Date/Time"
Range("A1:c1").Font.Bold = True
'Get Directory
F = Dir(Directory)
Do While F <> ""
r = r + 1
Cells(r, 1) = F
Cells(r, 2) = FileLen(Directory & F)
Cells(r, 3) = FileDateTime(Directory & F)
'Get next File
F = Dir()
Loop
End Sub

Break the password of protected excel sheet

Steps :
1. Open Excel Workbook
2. Go to developer Tab (http://msdn.microsoft.com/en-us/library/bb608625.aspx)
3.Click on Visual Basic icon
4.Go to Insert then Click on Module
5. Copy below code in Module
6.Open the workbook & select sheet, which you want to Unprotect
7. Run the Macro

Sub PasswordBreaker()
  Dim i As Integer, j As Integer, k As Integer
  Dim l As Integer, m As Integer, n As Integer
  Dim i1 As Integer, i2 As Integer, i3 As Integer
  Dim i4 As Integer, i5 As Integer, i6 As Integer
  On Error Resume Next
  For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
  For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
  For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
  For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    
       
 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
      Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
      Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
  If ActiveSheet.ProtectContents = False Then
      MsgBox "One usable password is " & Chr(i) & Chr(j) & _
          Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
          Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
   ActiveWorkbook.Sheets(1).Select
   Range("a1").FormulaR1C1 = Chr(i) & Chr(j) & _
          Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
          Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
       Exit Sub
  End If
  Next: Next: Next: Next: Next: Next
  Next: Next: Next: Next: Next: Next
End Sub

Find systems environment Information with vb

"Environ" : This Function return various Environment details ,all the Strings associated with an operating systems environment variables
This code is useful if you need to obtain info about your users operating system. The code loops through all the Environment variables available, and returns the name of the variable, and the string value associated with it. The Environ function is used to obtain things like the Windows Username, Userprofile, System root, etc

To Find User Name & Computer Name :

Sub envn()
MsgBox Environ("Username")
MsgBox Environ("Computername")
End Sub

To Find system Info :
Sub env()
Dim i As Long
Sheets.Add
For i = 1 To 56
    Cells(i, 1).Value = Environ(i)
Next i
Columns("A").AutoFit
End Sub

Determine physical address (MAC Address) of PC

Every network interface has a MAC address (Media Access Controller) also known as the physical address. This is the actual hardware address that the lowest level of the network uses to communicate.
The MAC address is used to assign the TCP/IP address by means of DHCP (Dynamic Host Configuration Protcol). For that reason, we need the MAC address of a machine so that it can be properly, and easily configured for the network.
You can enter ipconfig/all in cmd prompt and find Physical address i.e MAC address
vb code Try :
Sub MAC()
Dim strCom As String
Dim objWMIService As Object
Dim colAdapters As Object
Dim objAdapter As Object
strCom = "."
Set objWMIService = GetObject _
("winmgmts:" & "!\\" & strCom & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objAdapter In colAdapters
MsgBox "Physical address : " & objAdapter.MACAddress
Next objAdapter
End Sub

Open & Close CD Drawer from Excel

I found this on net, its amazing !



Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpCommandString As String, ByVal lpReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Public Sub OpenCDDoor()
Call mciSendString("set CDAudio door open", "", 0, 0)
End Sub

Public Sub CloseCDDoor()
Call mciSendString("set CDAudio door closed", "", 0, 0)
End Sub

Excel Can Speak

Sub Speak()
Application.Speech.Speak Range("A1")
End Sub

To Find the last used row & column

Sub LastRC()

Dim LR, LC
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
MsgBox LR
MsgBox LC
End Sub

Find columns Names And CONCATENATE with quama separated

Excel vb does not provides a function called Application.WorksheetFunction.CONCATENATE
If you want to find particular columns and combine the contents of columns cells with quama separated.you can use below vb code
For instance, let's say you wanted to Find columns with header FirstName,MiddleName,LastName,Product and add together the contents of columns cells,
separate them by a quama,if your last column contain blank rows or its blank, the formula will be drag till end of column.
All you need to do is put the below code in vb module.Run the Macro.
New column "Concatcolumns" will be added to your data at end of columns. with concatenation of columns mention and quama separated


Sub CONCATENATE()
Dim r, rng, c As String
Dim LR As Long
Dim Found1, Found2, Found3, Found4 As Range
Dim lastcol, delcol As Long
'code by : Mahesh Parab
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For delcol = lastcol To 1 Step -1
If Cells(1, delcol) = "Concatcolumns" Then _
     Cells(1, delcol).EntireColumn.Delete
Next
Set Found1 = Rows(1).Find(what:="FirstName", LookIn:=xlValues, lookat:=xlWhole)
Set Found2 = Rows(1).Find(what:="MiddleName", LookIn:=xlValues, lookat:=xlWhole)
Set Found3 = Rows(1).Find(what:="LastName", LookIn:=xlValues, lookat:=xlWhole)
Set Found4 = Rows(1).Find(what:="Product", LookIn:=xlValues, lookat:=xlWhole)
Cells(1, Columns.Count).End(xlToLeft).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Concatcolumns"
ActiveCell.Offset(1, 0).Select
c = "&"",""&"
ActiveCell.Value = "=" & Found1.Offset(1, 0).Address(False, False) & c & Found2.Offset(1, 0).Address(False, False) & _
c & Found3.Offset(1, 0).Address(False, False) & c & Found4.Offset(1, 0).Address(False, False)
r = Split(ActiveCell.Address, "$")(1)
rng = (":" & r)
LR = Cells(Rows.Count, "A").End(xlUp).Row
Selection.AutoFill Destination:=Range(r & ActiveCell.Row & rng & LR)
End Sub