Monday, September 28, 2015

Send excel range as mail body HTML & email


Many company requires to send Ledger summary to their client, which requires un-necessary copy & paste from excel to email, in this macro you need to select range which you want to email (In this case select yellow color highlighted cell) & press Alt + F8 to run macro.  A mail will be automatically created which will be ready to send.

Share your suggestion & feedback.


Click to Download

Thursday, August 20, 2015

Excel formula to calculate commission on sales for different slabs


Although a flat-rate sales commission is fairly straightforward to calculate, most modern commission plans include tiers and bonus plans. In this post I will explain how to calculate a commission payout where slab structure is involved. Calculating commissions for as slab structure is difficult because you are required to calculate commission for different slabs at the different rate.

Below given us slab used for given example:

Sales Amount
Commission %

so for commission for sales upto 20k is nil, for next 10k it is 5% of amount in excess of 20k and so on..

Refer excel attachment for formula & in 1st sheet & example for understanding in second sheet.


Click to Download

Saturday, August 15, 2015

Excel VBA Macro to assign payment received to Invoices using FIFO method


Today i am sharing this fantastic template for assigning payment received to Invoices using FIFO method.

If you are not using any ERP or Accounting package then it is nightmare for accountant to manually assign payment received one by one to invoice, also there is risk of assigning payment twice or missing payments..

Just fill data in template & click on Image to run macro..

Download file by clicking this.



Saturday, August 8, 2015

Windows like calculator in excel using VBA macro

While working with excel need for calculator arises for doing manual calculations..

follow this link for downloading excel with free VBA codes:

With this calculator in excel you can do basic functions & trigonometric functions too, also it has option for deleting last miss typed texts..


Saturday, August 1, 2015

Excel VBA Extract domain name from email address using Excel VBA Macro

Excel VBA Extract domain name from email address using Excel VBA Macro

How to Extract, follow steps as below:

Step 1 : Split email id from @ sign
Step 2: Get second portion of split result
Step 3: Now in domain name there could be more than one dots, so we will split value in step 2 using "." sign
Step 4: Store values so split in to array & remove last array
Step 5 : Remove last array value
Step 6 : Join array value using "."
Step 7: Result is your domain name

Check Code:
Sub domain_name_old()

Dim a() As String

Dim domain As String

domain = "" 'ActiveCell.Value

domain = Split(domain, "@")(1)

a = Split(domain, ".")

ReDim Preserve a(UBound(a) - 1)

domain = Join(a, ".")

MsgBox "Domain name is : " & domain

End Sub

Method 2 ***

Sub domain_name2()
Dim a() As String
Dim domain As String
domain = ActiveCell.Value
domain = Split(domain, "@")(1)
domain = Replace(domain, "." & Right(domain, (Len(domain) - InStrRev(domain, "."))), "")
End Sub

Friday, July 17, 2015

Employee Roster / Shift allocation template


Preparing employee roster or allocation of shift times is very time consuming & requires accuracy so as to avoid any emergencies.

In this template you need to fill data in Main sheet in front of each employee & press Run All button & all shifts will be marked in respective sheets against each employees.

For changing shift allocated time, just change shift time in main sheet & same will be replicated in respective day sheet automatically.

Column R is for entering maximum time an employee is allowed to work, enter hrs manually in column R, column S will calculate total Hours allocated & balance hours in column T.

To Reset all data in all sheets, Just press Rest All Data button.

When you click on name of Day in column 4 you will be taken to that day sheet directly & from day sheet click on Main in Cell Q1 to come back to Main sheet..

Cheers & waiting for feedback for improvements..


Tuesday, June 23, 2015

Find text in all sheet & return Sheet Name & Header in new Excel sheet

You can use below code for find particular text in all sheets

'Run from standard module, like: Module1.

    'Find all data on all sheets!

    'Do not search the sheet the found data is copied to!

    'List a message box with all the found data addresses, as well!

    Dim ws As Worksheet, Found As Range

    Dim myText As String, FirstAddress As String

    Dim AddressStr As String, foundNum As Integer

    myText = InputBox("Enter text to find")

    If myText = "" Then Exit Sub

    For Each ws In ThisWorkbook.Worksheets

    With ws

    'Do not search sheet4!

    Set Found = .UsedRange.Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

    If Not Found Is Nothing Then

    FirstAddress = Found.Address


    foundNum = foundNum + 1

    'AddressStr = AddressStr & .Name & "," & Found.Address & vbCrLf

    AddressStr = AddressStr & .Name & "//" & Found.Address & "//" & ws.Cells(1, Found.Column).Value & ";" & vbCrLf

    Set Found = .UsedRange.FindNext(Found)

    'Copy found data row to sheet4 Option!

    'Found.EntireRow.Copy _

    'Destination:=Worksheets("Sheet4").Range("A65536").End(xlUp).Offset(1, 0)

    Loop While Not Found Is Nothing And Found.Address <> FirstAddress And Found.Column <> Range(FirstAddress).Column

    End If


    End With

    Next ws

    If Len(AddressStr) Then

    MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _

    AddressStr, vbOKOnly, myText & " found in these cells"


    Set ws = Sheets.Add(After:=Sheets(Sheets.Count))

    ws.Name = "Report"


    Range("A1").Resize(foundNum, 1) = Application.Transpose(Split(AddressStr, ";"))


    MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation

    End If



End Sub

Saturday, June 20, 2015

Convert all picture in folder to single pdf using Excel VBA


Photographer n Artist can now send all their pic in one PDF to client instead of zip file...Following code will help them to import all pictures stored in folder & convert them to handy PDF which can be shared on the go...

Sub Add_PIC_Save_PDF() Dim strPath As String Dim strFileName As String Dim Pic As Picture Dim sh As Worksheet Dim n As Integer Dim cl As Range Application.DisplayAlerts = False Application.ScreenUpdating = False n = ThisWorkbook.Worksheets.Count strPath = "C:\Users\ABC\Desktop\test\" ' change folder to suit strFileName = Dir(strPath & "*.png") ' change file type to suit Set sh = ActiveSheet Do While Len(strFileName) > 0 sh.Select Set Pic = ActiveSheet.Pictures.insert(strPath & strFileName) Range("A1").Select With sh Set cl = sh.Range("A1") With PicSize PicSize.Top = cl.Top PicSize.Left = cl.Left PicSize.Placement = xlMoveAndSize End With With sh.PageSetup .Orientation = xlLandscape .FitToPagesWide = 1 .FitToPagesTall = 1 .Zoom = False .LeftMargin = Application.InchesToPoints(0) .RightMargin = Application.InchesToPoints(0) .TopMargin = Application.InchesToPoints(0) .BottomMargin = Application.InchesToPoints(0) .HeaderMargin = Application.InchesToPoints(0) .FooterMargin = Application.InchesToPoints(0) .PrintQuality = 4000 End With strFileName = Dir End With Set sh = Sheets.Add(After:=Sheets(Sheets.Count)) Loop
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\ImageToPdf.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Do let me know your views..


Monday, June 15, 2015

Hide / delete all shapes/pictures falling on particular range in sheet

Hi Friends

Many time you need to clear all unwanted shapes from particular range by deleting or hiding, and since shapes/ pictures doesn't reside in cells but floats above it which makes it difficult to manage, we can use following code to manage floating shop per our need:

Sub Hide_Shapes()

Dim s As String

Dim sObject As Shape

Dim rng As Range

Set ws = ActiveSheet

'Set ws = ActiveWorkbook.Worksheets("Sheet1")

Set rng = ws.Range("A:C,BC:BD")

For Each sObject In ws.Shapes

With sObject

s = .TopLeftCell.Address & ":" & .BottomRightCell.Address

End With

If Not Intersect(rng, ws.Range(s)) Is Nothing Then

sObject.Visible = msoFalse

'use below line for deleting shape


End If


End Sub

Do let me update your views, 

Sunday, June 14, 2015

Excel Macro - Sheet Manager

Hi Excel champs,

Today i want o share with you a powerful macro for those who are dealing with lots of sheets in single book & wish to hide unhide sheet very frequently..

This macro has module wherein on loading this you will get 2 listboxes, listbox1 will show all visible sheets & listbox2 will show all hidden sheets..

If you want to hide any sheets from those visible ones, juts select sheet name one by one from left listbox & click on 1st button (>) in center..

If you want to unhide any sheets from those hidden ones, juts select sheet name one by one from right listbox & click on 2nd button (<) in center..

On contrary if you want to hide all visible sheets then click 3rd button (>>>) in center & if you want to unhide all hidden sheets then click 4th button (<<<).

And if you have loads of sheet then above all list box there is one textbox to filter sheets, just type name of sheet & data will get filtered & select sheet name & push it to opposite side.

Please note you can not hide all sheet so i have kept sheet named "Main" out of reach of code which will be by default visible..

Also you can double click on name of item appearing listbox to move that on opposite side & after that click button Hide / Unhide to give impact..

You can also use shortcut key Ctr + Shft + W to load Sheet Manager macro.

Let me know if you liked it or not.

Monday, June 8, 2015

Transpose data from Table to One Column / Multiple rows with heading


We know trick to transpose data from row to column & vice versa, however in the edge of ERP many system requires data in Table to be transposed in to one column which is very difficult to do manually when you have n numbers of rows of data.

Formula used is offset x no. of Rows & y no. of column from Starting cell.

here you can name your starting cell as START by going to name manager,

--Number of row to be offset is 2 divide by number of columns in table;
--Number of column to be offset is "z" divide by "z" divide where z is number of columns in table;

Refer attached sheet with formula to do so..


Thursday, May 28, 2015

Populate value in combo box as you type data / Serach box using combo box

In combo box you can populate values from list or excel range, but you need google type search box to fetch only unique values & to also list to change on stroke of you enter value in combo box!!


Friday, April 17, 2015

Auto close excel workbook if inactive for 5 secs

If you want that if user is inactive for certain period say 5 secs than excel file to close automatically then yes it is possible:

Use below code:

In WorkBook module:

Private Sub Workbook_Open()
    EndTime = Now + TimeValue("00:00:05") ' Change time limit
End Sub

In Worksheet Module:

Private Sub Worksheet_Change(ByVal Target As Range)

    If EndTime Then

        Application.OnTime _

        EarliestTime:=EndTime, _

        Procedure:="CloseWB", _


        EndTime = Empty

    End If

    EndTime = Now + TimeValue("00:00:05") ' Change time limit


End Sub
In Standard Module:

Public EndTime

Sub RunTime()

    Application.OnTime _

    EarliestTime:=EndTime, _

    Procedure:="CloseWB", _


End Sub

Sub CloseWB()

    Application.DisplayAlerts = False

    With ThisWorkbook

        .Saved = True


    End With

End Sub


Click Download Example with Timer in it:

Tuesday, January 13, 2015

Excel VBA move PDF files to specific folder


Lets say you have your employee files or customer files in a single folder with employee name /customer name in the beginning (say 1st six digit).

Now you want to move all of them to individual employee / customer wise folder?

Tons of thousands of employees /customers & cant do manually.. Here goes macro...

Sub move_PDF()

Dim fldr As FileDialog

Dim emp As String, SourceFldr As String, DestFldr As String

Dim FileToOpen As Variant

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

With fldr

    .Title = "Select a Source Folder"

    .AllowMultiSelect = False

    .InitialFileName = strPath

    If .Show <> -1 Then GoTo NextCode

    SourceFldr = .SelectedItems(1) & "\"


End With

With fldr

    .Title = "Select a Destination Folder"

    .AllowMultiSelect = False

    .InitialFileName = strPath

    If .Show <> -1 Then GoTo NextCode2

    DestFldr = .SelectedItems(1) & "\"


End With

FileToOpen = Dir(SourceFldr & "*.pdf")

Do While FileToOpen <> ""

'check if folder exists

Dim FSO As Object

Set FSO = CreateObject("scripting.filesystemobject")

emp = Left(FileToOpen, 6)

If FSO.FolderExists(DestFldr & emp) = False Then

MkDir DestFldr & emp

End If


'Move file

Name SourceFldr & FileToOpen As DestFldr & emp & "\" & FileToOpen

FileToOpen = Dir


MsgBox "Files moved"

End Sub


Excel VBA get extended property for Image file


There are 287 extended property, to get Image info you can use following code:

Option Explicit

Sub GetImageInfo()

Dim i As Integer, SourceFldr

Dim c As Range, rng As Range

Dim sFile As Variant

Dim oWSHShell As Object

Dim fldr As FileDialog

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

Set oWSHShell = CreateObject("WScript.Shell")

With fldr

    .Title = "Select a Source Folder"

    .AllowMultiSelect = False

    .InitialFileName = oWSHShell.SpecialFolders("Desktop")

    If .Show <> -1 Then GoTo NextCode

    SourceFldr = .SelectedItems(1)


End With

Dim oShell: Set oShell = CreateObject("Shell.Application")

Dim oDir:   Set oDir = oShell.Namespace(SourceFldr)

i = 3


For Each sFile In oDir.Items

    Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)   'File Name

    Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 1)   'File Size

    Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 2)   'File Type

    Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 5)   'Date Created

    Cells(i, 5).Value = oDir.GetDetailsOf(sFile, 12)  'Date Taken

    Cells(i, 6).Value = oDir.GetDetailsOf(sFile, 31)  'Dimensions

    Cells(i, 7).Value = oDir.GetDetailsOf(sFile, 160) 'Bit Depth

    Cells(i, 8).Value = oDir.GetDetailsOf(sFile, 164) 'Height

    Cells(i, 9).Value = oDir.GetDetailsOf(sFile, 162) 'Width

    Cells(i, 10).Value = oDir.GetDetailsOf(sFile, 161)'Horizontal Resolution

    Cells(i, 11).Value = oDir.GetDetailsOf(sFile, 163)'Vertical Resolution

i = i + 1


    Set oDir = Nothing

    Set oShell = Nothing


MsgBox "Done"

End Sub