Send excel range as mail body HTML & email

Hi,

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.

Cheers!!


Click to Download

Excel formula to calculate commission on sales for different slabs

HI,

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 %
20000	0%
30000	5%
40000	7%
50000	10%
60000	12%
70000	13%
80000	14%
90000	15%
100000	16%
110000	17%
120000	18%
130000	19%
99999999	19%

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.

Cheers!!


Click to Download

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

Hi

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.


Cheers!!

Tags:
#Excel#VBA#MACRO#FIFO#INVOICE#PAYMENT

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..

Download

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 = "vba@sub.domain.com" '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

Employee Roster / Shift allocation template

Hi,

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..

Cheers!!

Download Attachment

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



    Do

    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



myNext:

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

    Else:



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

    End If

   

    Columns("A:A").AutoFit

End Sub

Convert all picture in folder to single pdf using Excel VBA

Hi,

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


sh.Delete


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..

Cheers!!

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

'sObject.Delete

End If

Next

End Sub

Do let me update your views, 

Cheers!!

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.

Click here to download sheet

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

Hi,

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.

Explanation:

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..

Download

Cheers!!

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!!


Download

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
    RunTime
End Sub

In Worksheet Module:

Private Sub Worksheet_Change(ByVal Target As Range)

    If EndTime Then

        Application.OnTime _

        EarliestTime:=EndTime, _

        Procedure:="CloseWB", _

        Schedule:=False

        EndTime = Empty

    End If

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

    RunTime

End Sub

In Standard Module:

Public EndTime

Sub RunTime()

    Application.OnTime _

    EarliestTime:=EndTime, _

    Procedure:="CloseWB", _

    Schedule:=True

End Sub

Sub CloseWB()

    Application.DisplayAlerts = False

    With ThisWorkbook

        .Saved = True

        .Close

    End With

End Sub

Cheers!!

Click Download Example with Timer in it:

Excel VBA move PDF files to specific folder

Hi

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

NextCode:

End With



With fldr

    .Title = "Select a Destination Folder"

    .AllowMultiSelect = False

    .InitialFileName = strPath

    If .Show <> -1 Then GoTo NextCode2

    DestFldr = .SelectedItems(1) & "\"

NextCode2:

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

Loop



MsgBox "Files moved"

End Sub

See Attachment

Cheers!!

Excel VBA get extended property for Image file

Hi

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)

NextCode:

End With



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

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



i = 3

Range("A3:K5000").ClearContents



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

Next

    Set oDir = Nothing

    Set oShell = Nothing

Cells.Columns.AutoFit

MsgBox "Done"

End Sub

See attachment.

Cheers!!

Vaibhav