Wednesday, May 11, 2016

Excel VBA Macro Delete all images / drawing objects from sheet in one go

Excel VBA Macro code to Delete all images / drawing objects from sheet in one go:

Sub DelObjects()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
          On Error Resume Next
Next sh
MsgBox "Done!"
End Sub


Sunday, May 1, 2016

Excel formula to find overlapping dates in columns

Query: I have a range of dates, start date and end date in a single row in below format.

I want to check for overlap for in each row using formula .


An overlap exists if any of end date is equal to or lesser than start date for other blocks or any of  start date is equal to or greater than end date for other blocks.

We will compare each end date for criteria 1 & compare each start date criteria 2 as mentioned above using following formula.

=IF(SUMPRODUCT((INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,)<=TRANSPOSE(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)))*(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)>=TRANSPOSE(INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,))))>1,"Overlap","No Overlap")

Download sample file.

Post your feedback below & write your query to www.ExcelVbaLab.Com


Monday, April 25, 2016

Excel formula : Find Bottom 5 values excluding zero


I have list of numbers from that i want to extract smallest 5 numbers excluding zero.


we can use combination of Small & count if to get the same. Copy below formula and paste down to cell B1 to B5


Here first count if formula will count for count of numbers equal to zero & will add 1 to it for finding lowest number greater than zero and so on.


Wednesday, April 20, 2016

Excel VBA macro highlight break in attendance / gap in dates

Query: I have downloaded attendance data/log from application employee wise, I want to highlight break days. e.g. if an employee has worked from 1 to 15th , and his next attendance is on 22nd I want to highlight 22nd and similar such data. Also there 5 working days for some employees & 6 working days for others. All Sundays are compulsory holidays & Saturday is extra holidays for those who are working for 5 days.

Data format is as below:


Again we will use VBA to get work done, sequence will be :

Read EmpID & Date into array,
Sort array EmpID wise & then date wise using bubble sort method.
Now loop through value in array & check for break.

Code goes here:

Sub spot_break_rev()

Dim Arr() As Variant
Dim Temp As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim k As Long

lr = Range("A" & Rows.Count).End(xlUp).Row
With Cells.Interior
     .Pattern = xlNone
     .TintAndShade = 0
     .PatternTintAndShade = 0
End With
'Allocate value to dynamic array
ReDim Arr(0 To lr - 2)
'Fill the array with the keys from the Dictionary
For i = 0 To lr - 2
    Arr(i) = Cells(i + 2, "A") & "^" & Cells(i + 2, "C") & "~" & i + 2
Next i
'Sort the array using the bubble sort method
'Sory by emp code
For i = LBound(Arr) To UBound(Arr) - 1
    For j = i + 1 To UBound(Arr)
        If Arr(i) > Arr(j) Then
           Temp = Arr(j)
           Arr(j) = Arr(i)
           Arr(i) = Temp
           End If
    Next j
Next i

'Sort the array using the bubble sort method
'Sory by date if any left out
For i = LBound(Arr) To UBound(Arr) - 1
    For j = i + 1 To UBound(Arr)
    If Split(Arr(i), "^")(0) = Split(Arr(j), "^")(0) Then
           If Split(Arr(i), "^")(0) > Split(Arr(j), "^")(0) Then
           Temp = Arr(j)
           Arr(j) = Arr(i)
           Arr(i) = Temp
           End If
    End If
    Next j
Next i

For i = LBound(Arr) To UBound(Arr) - 1
    k = 0
    If Split(Arr(i), "^")(0) = Split(Arr(i + 1), "^")(0) Then
       If (CDate(Split(Split(Arr(i), "^")(1), "~")(0)) + 1) * 1 <> _
          (CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) * 1 Then
          If Day(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) <> 7 Then
             If Cells(Split(Arr(i + 1), "~")(1), "D") <> 6 Then 'chage column no. of days
             Cells(Split(Arr(i + 1), "~")(1), "A").EntireRow.Interior.Color = vbYellow
             End If
          End If
       End If
       k = k + 1
    End If
    If k = 0 Then
    Cells(Split(Arr(i), "~")(1), "A").EntireRow.Interior.Color = vbYellow
    End If
    If k = 0 And i = UBound(Arr) - 1 Then
    Cells(Split(Arr(i), "~")(1) + 1, "A").EntireRow.Interior.Color = vbYellow
    End If
Next i

End Sub

You can download file from here:

Provide us your valuable feedback & post your query on www.ExcelVbaLab.Com


Sunday, April 17, 2016

Excel Unique & Difficult formula : Find date when target is achieved (Running total / Cumulative sum for item exceeding target)


I want a formula for searching date when a total target for particular agent exceeds between select dates. Basically, I have data sheet in which there is a date wise running sales of each agent, there is not a column of running total for each agent in it. I want to know for between any given dates, in a summary sheet for an agent on which date sales has exceeded a given target.

My database is maintained as below

I want a result in the last column from above date


Since you are trying to extract result for not standard date range adding running total column will be of no use. Let's construct formula get the desired result:

Step -1 So first we will require to fetch a range which matches an agent name and which is within a date specified, 


Above formula will give row number of meeting criterion we can get cell address by using formula

=(Data!$C$2:$C$1000)*( if (Step1_Formula>0,1,0) ),

so revised formula will be :


Here we are checking that if in step 1 formula if a value is zero (i.e. nonmatching item then keep row number to zero else keep this as 1, and multiply this array to data range to get the address of the matching value.

Step -2 Now since we have extracted the daily sales value of required criterion, then we will convert this daily sales value to cumulative sales value. E.G. we have extracted sales values as {100,100,0,0,100} but what we need to match is cumulative sales i.e. {100,200,200,200,300}.

To convert 1st array {100,100,0,0,100} to {100,200,200,200,300} we will use Matrix Multiplication formula, i.e. MMULT.

E.G. You have data in cell A1 to A5 as 1,2,3,4,5 and when you use MMULT formula as follows:


Formula will return cumulative sum as {1,3,6,10,15}, i.e. cumulative sum is returned in array. Note MMULT is an array formula so after entering formula instead of pressing enter, use the combination of CSE keys (Control + Shift + Enter keys).

so our formula will look like as below:


Step -3 As we have received cumulative sum/total we can use LOOKUP formula & get resultant day by assigning array to it by using formula:

=LOOKUP(E8, Step2_Formula, Data!$A$2:$A$1000)+1

So final formula will look like this: 


Enter above formula as an array to get the desired result.

Comment about this article & post your query below, also you can ask your query on www.ExcelVbaLab.Com


Wednesday, April 13, 2016

Excel Pivot table - Conditional formatting pivot table & maintaining format after filtering and un filtering data

Query: I have a pivot table and I want to have the format apply to any cell in the data area, regardless of the configuration of the column and row fields. I want the formatting to fit whatever the table displays and also same to get refreshed whenever data is refreshed. I tried applying it but as soon as data is filtered out conditional formatting gets lost.

Solution: You can follow steps as below:

Step 1 - Select whole  data area,
Step 2 - click on Conditional Formatting on the Home tab of the Ribbon and choose the conditional format you want to apply.
Step 3 - Click on rectangle box at the right end corner,
Step 4 - Select the last option from radio button,

You can also refer below image

Post your query and feedback on


Tuesday, April 12, 2016

Excel VBA Macro to compare employee data head wise between multiple sheet and give out to separate sheet

Query: Hi I have employee master data in two or sometimes three or more sheets, I want to match data in all sheets and get the comparison in new sheets, where macro to check head wise employee wise amount and highlight if miss match.


Since there are multiple sheets to compare, we need to loop through all sheets & take unique employee number from all sheets, and similarly extract unique headers from all sheets.

Once we have extracted the same we can generate the ouput in new sheet where we can pull employee details and corresponding head wise amount from different sheet, then we can match amount in next column and highlight the same.

Code goes here:

Option Explicit
Sub Generate_Diff_V2()
Dim key As Variant
Dim cell As Range, cell2 As Range
Dim wb As Workbook
Dim i As Integer, j As Integer
Dim dict As Object, dict2 As Object
Dim cell3 As Range
Set wb = ThisWorkbook
Dim app

Set app = Application.WorksheetFunction
Set dict = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False

For i = 1 To wb.Worksheets.Count
If Sheets(i).Name <> "Output" Then

For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Not dict.exists(Val(cell)) Then
dict.Add Val(cell), cell.Offset(0, 1)
End If

For Each cell In Range(Range("C1"), Cells(1, Range("A1").End(xlToRight).Column))
If Not dict2.exists(cell.Value) Then
dict2.Add cell.Value, cell.Value
End If

End If

Next i
Cells(3, 1).Resize(dict.Count) = Application.Transpose(dict.Keys)

For Each cell3 In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
cell3.Offset(0, 1).Value = dict(Val(cell3))
Next cell3

Dim k As Integer
Dim rr As Long, cc As Long

k = 2
Cells(2, 1).Value = "ID"
Cells(2, 2).Value = "Name"

For Each key In dict2.Keys
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Output" Then

Cells(1, k + 1).Value = key
Cells(2, k + 1).Value = Sheets(i).Name

On Error Resume Next
cc = 0
cc = Sheets(i).Range("A1:ZZ1").Find(key, LookIn:=xlValues).Column

For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
On Error Resume Next
rr = 0
rr = Sheets(i).Range("A1:A100000").Find(cell.Value, LookIn:=xlValues).Row
If rr <> 0 And cc <> 0 Then
cell.Offset(0, k).Value = Sheets(i).Cells(rr, cc).Value
cell.Offset(0, k).Value = 0
End If
Next cell

k = Range("ZZ3").End(xlToLeft).Column  'k + 6

End If
Next i

Cells(2, k + 1).Value = "Diff"
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
'For j = 1 To Worksheets.Count - 1 'dict2.Count
'cell.Offset(0, k).Value = cell.Offset(0, k).Value - cell.Offset(0, k - j).Value
'Next j
j = Worksheets.Count - 1
cell.Offset(0, k).Value = app.Max(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1))) _
= app.Min(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1)))
If Not cell.Offset(0, k).Value Then
cell.Offset(0, k).Interior.Color = vbRed
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column + 1 'k + 6

Next key

Application.ScreenUpdating = True

End Sub

You can also download sample file from here:

Post your query & comments below, you can also post your query at


Friday, April 8, 2016

Excel formula to find 1st 2nd (second) 3rd (third) to Nth occurrence in range and match multiple conditions through different columns

Query : I have database containing many columns, i have different tab/sheet for report sheet, in that I have to match values from two columns and extract matching values, problem is that my database there are same values in all two columns, so i want to match & extract 1st instance for 1st case, 2nd instance for second case and so on.

Data is in sheet in below format:

I want report in below format:

Solution: We can use an array formula to match multiple conditions & extract values, but I always try to avoid array formula since I believe it is heavy on sheet when it contains large. This formula is unique since I have tried using Large() function & used index to receive an array value in single column.

I have use following formula:


Step 1: Get row number for matching condition usinh Index Formula:


Step 2: To handle repeated values; we need to first fiind total matching values form that total count we will deduct instance of repetation at particular row, this will give us largest matching value for specific cell. Eg.In given report XYZ is repeated 3 times, but for finding value in cell C1 we will find third largest value, for finding value in cell C2 we will find second largest value & for finding value in cell C3 we will find first largest value. This can be arrived by using:


Step3: If we put array result of step1 & result of step 2 in function Large() we will get row number of matching value, so formula will be :

=LARGE(INDEX(ROW(DATA!$A$2:$A$19)*(DATA!$B$2:$B$19=A2)*(DATA!$A$2:$A$19=B2),,1), SUMPRODUCT(($A$2:$A$7=A2)*($B$2:$B$7=B2))-SUMPRODUCT(($A$2:A2=A2)*($B$2:B2=B2))+1)

Step 4: Using Address formula to convert row number to cell refferrence (address) of destination cell.

=ADDRESS( step3 formula , COLUMN(D1),1,1,"DATA")

Here we used COLUMN(D1) because required result in column D.

Step 5: Using Indirect() function to converer cell address in  Step 4 to required result.

Download Example file

Please give your feedback & you can ask your query in iur open form www.ExcelVbaLab.Com


Monday, April 4, 2016

Excel VBA File Upload & Download Manager / File copy paste from one location to another

If you have shared folder without control of who is a uploading & downloading (copying) file, there a simple solution to it. Through this file a manager you can keep a store of your shared folder.

In this macro i have kept C:\temp as default folder which you can change as per your choice, Run macro & select option either upload & download.

When you select download you will be asked to C:\temp folder & you can select file to be download, select file & after that you will be prompted for destination folder where you want to downalod/copy file. Enter file description if any & you are done.

Similarly, for uploading a file you will be prompted to select a file to be uploaded to default folder, select file & file will be copied/uploaded to a default folder.

Click to Download File

Give Feedback & Recommendation

tag:Excel VBA File Upload & Download Manager / File copy paste from one location to another

Tuesday, March 29, 2016

Outlook VBA Macro to group unread email with subject containing Excel & forward all email as attachment to specific email ID

Query: I want to automate incoming emails on the basis of its subject, if this contains word excel I want to attach all such email to new email as a mail item & forward it to particular email ID.


We can create loop for all unread email in outlook & check whether it is unread & contains word Excel, and if contains then add email item as an attachment & forward to defined recepient.

Option Explicit

Sub ConsolEmail()

Dim objMailItems As Items

Dim objMail As Object

Dim ns As NameSpace

Dim mFound As Boolean

Set ns = Application.GetNamespace("MAPI")

Set objMailItems = ns.GetDefaultFolder(olFolderInbox).Items


'Assign the email address to forward items to

Dim msgList As String

msgList = ""


'Assign Subject

Dim msgSub As String

msgSub = "Excel"

mFound = False

'Create new email

Dim objNewMail As Object

Set objNewMail = Application.CreateItem(olMailItem)


'Forward each item as attachment

For Each objMail In objMailItems

'Debug.Print objMail.Subject

    If objMail.UnRead = True And _

     InStr(1, objMail.Subject, msgSub, vbTextCompare) > 1 Then

    objNewMail.Attachments.Add objMail

    objMail.UnRead = False

    mFound = True

    End If


If mFound Then

objNewMail.To = msgList

objNewMail.Subject = "Group email for " & msgSub



'objNewMail.Send ' untag this line for sending email instead of displaying

End If

MsgBox "One operation completed"


Set objMail = Nothing

Set objMailItems = Nothing

Set objNewMail = Nothing

End Sub

Do give your feedback & post your query on form



Monday, March 28, 2016

Excel formula to get total of/sum of all digits(number) in a cell

Query: I have got numbers in cell, i want to find total of all digits (number) in a particular cell.

e.g. If in cell A1 there is number 1234, then i want total/sum of 1+2+3+4=10 in next cell.

Answer: We can achieve this result using SUMPRODUCT formula,

formula is =SUMPRODUCT(--MID(A1,ROW(INDIRECT("1:" & LEN(A1))),1))


tag: #EXCEL #FOORMULA  #total #of/sum of all #digits(number) in a #cell

Friday, March 25, 2016

Excel VBA Macro to Import sheet from all file in folder and then merge first two columns in to master sheet

Hi Every one.

It is big pain for MIS guys to import data from many files to the master file and manipulate the same. Below macro will import all Only Active sheet from each file into the master workbook, after impoting sheets, it will copy first two columns and keep last 10 character from it.

Option Explicit

Sub Merge_All_Excel()

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Dim sn(9999) As String

Dim xDir$, fName As String

Dim sheetname As String

Dim master As Workbook, import As Worksheet, file2 As Workbook

Dim r As Long, i As Long

Dim xt As String

Dim lr As Long

Set master = ThisWorkbook


With Application.FileDialog(msoFileDialogFolderPicker)

     .InitialFileName = Application.ThisWorkbook.Path & "\"

     .Title = "Please select a folder containing files"


If .SelectedItems.Count <> 0 Then

   xDir$ = .SelectedItems(1) & "\"

End If

End With


fName = Dir(xDir$)

    r = 1

    Do While Len(fName) > 0

        If UCase(Split(fName, ".")(UBound(Split(fName, ".")))) = "CSV" Or _

        Left(UCase(Split(fName, ".")(UBound(Split(fName, ".")))), 2) = "XL" Then

        sn(r) = fName

        r = r + 1

        End If

        fName = Dir


    On Error Resume Next

    For i = 1 To r - 1

        Workbooks.Open xDir$ & sn(i), ReadOnly:=True

        Set file2 = ActiveWorkbook

        Set import = file2.ActiveSheet

        import.Copy After:=master.Sheets(master.Sheets.Count)

        file2.Close False



        xt = Split(sn(i), ".")(UBound(Split(sn(i), ".")))

        sheetname = Replace(sn(i), "." & xt, "")

        master.ActiveSheet.Name = sheetname

    Next i

Dim shCount As Integer

Dim col As Integer

Dim sh As Worksheet

Dim dRng As Range

Dim cell As Range

Dim LastCell As Range

Dim rng2 As Range

Set sh = Sheets("MASTER")



shCount = Sheets.Count

col = 1

For i = 1 To shCount

If Sheets(i).Name <> "MASTER" Then


Set dRng = sh.Cells(1, col)

dRng.Resize(1, 2).Value = Sheets(i).Name

lr = Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row

Set dRng = sh.Cells(2, col)

Sheets(i).Range("A1:B" & lr).Copy


dRng.PasteSpecial xlPasteValues

col = col + 2

End If



Application.CutCopyMode = False


Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row, Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

Set rng2 = Range(Range("A3"), LastCell)

For Each cell In rng2

If cell.Value <> "" Then

cell.Value = Right(cell.Value, 10)

End If

Next cell


Application.ScreenUpdating = True

Application.DisplayAlerts = True

MsgBox "Done", Title:="www.ExcelVbaLab.Com"


End Sub

Do write your feedback & post your excel VBA macro related query on www.ExcelVbaLab.Com


Tags: #Excel #VBA #Macro to #Import #sheet #from all #files in #folder and then #merge #first two columns into #master #sheet

Excel Formula double lookup, match heading & sub heading and lookup data from main table


I have a data structure like heading & subheading. Each heading has four subheadings, I want to lookup a data by matching heading & then subheadings, refer data below:

Data is like below:

I want output in below format:


First we need to match heading & get location of heading & after that we can create specific range related to heading for searching & apply Hlookup formula in that ramge to get result.

Formula 1 : =HLOOKUP(B$7,OFFSET($A$1,2,MATCH($A8,$A$1:$AB$1,0)-1,2,4),2,0)

Formula 2: =INDEX($A$1:$AB$4,4,MATCH($A8,$A$1:$AB$1,0))

Formula 1 is though complecated but gives result in case of there is jumble or interchange in sub headings.

Comment or write to us on forum for clarifications or to post your querries


Tags: #Excel #Formula #double #lookup, #match #heading & #subheading and #lookup #data #from #main #table #to #Sub #Table

Wednesday, March 16, 2016

Multi column combo box.

Multi column combo box..

Have you ever come across situation wherein you want to show multiple items in combo box with description, but on selection you want to restrict it to only 1st item..

So we will have different view item in combo box & different result value.

See attached file for such example.

Click to Download


Excel VBA Macro to copy data from two sheets to third sheet

Query: I want to copy data from two two sheets to third sheet, I have sheet 1 & sheet 2 having multiple columns & rows, some columns in both the sheet have same header, i want to copy few of them to third sheet. So match haeding in sheet 1  copy all data till last row and paste it to last sheet, same for sheet2. Copy data for all column header in last sheet.

Make sure haeader in all sheet is similar & we can make macro to search through header in sheet 1/Sheet 2 & if header matches copy data from sheet 1 & paste it to last sheet.

Use below code:
Option Explicit

Sub copy_data_from _two_sheets_to_Summary_sheet()

    Dim Rng As Range, c As Range

    Dim sCell As Range

    Dim rSize As Long

    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet


    Set sh1 = Sheets("File 1")

    Set sh2 = Sheets("File 2")

    Set sh3 = ThisWorkbook.ActiveSheet


    sh3.[A2].Resize([A2].End(xlDown).Row - 1, 1).EntireRow.Clear

    Set Rng = sh3.Range([A1], [A1].End(xlToRight))

    For Each c In Rng

        'Copy data from Sheet 1

        Set sCell = sh1.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

        If Not sCell Is Nothing Then

        rSize = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

        If c.Offset(1, 0).Value <> "" Then

            c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value


            c.Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        End If

        End If


        'Copy data from Sheet 2

        Set sCell = sh2.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)

        If Not sCell Is Nothing Then

        rSize = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

        If c.Offset(1, 0).Value <> "" Then

            c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value


            c.Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

        End If

        End If




    MsgBox "Done"

End Sub


Tuesday, March 15, 2016

Excel VBA Macro Match / Compare two sheets and list out distinct values of both in new sheets


I have data in sheet1 & similar data in sheet2, however, few of rows cell data is changed, I want to bring all extra data from both the sheet to new sheet with row number so that i can check & correct them one by one.


I assume that a number of rows are same & each row has index number in acolumn then using below macro you can search for distinct values in both the sheet & bring them to a new sheet. Download sample file from below:

Click to Downlod

Option Explicit

Sub Compare_List_Diff()

Dim arrM, d As Object, rngM As Range

Dim arrT, d2 As Object, rngT As Range

Dim r As Integer

Dim wsM As Worksheet, wsT As Worksheet, wsR As Worksheet

Dim iRW As Integer, iCL As Integer

Dim LastCell As Range, LastCell2 As Range, LastCell3 As Range

Dim wsMlr As Integer, wsMlc As Integer

Dim wsTlr As Integer, wsTlc As Integer

Set d = CreateObject("Scripting.Dictionary")

Set d2 = CreateObject("Scripting.Dictionary")

Set wsM = Worksheets("Sheet1")

Set wsT = Worksheets("Sheet2")

Set wsR = Worksheets("Diff")

With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

.AskToUpdateLinks = False

End With

'get last row of Main


Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsMlr = LastCell.Row

wsMlc = LastCell.Column


Set LastCell2 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsTlr = LastCell2.Row

wsTlc = LastCell2.Column


Set LastCell3 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsR.Range("2:" & LastCell3.Row).Clear

For iRW = 2 To wsTlr

    'trf main sheet row data to arr and store in dict

    Set rngM = wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc))

    arrM = Application.Transpose(rngM)

    'arr = Application.Transpose(wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc)))


    For r = 1 To UBound(arrM, 1)

    If arrM(r, 1) <> "" Then

    d(arrM(r, 1)) = 1

    End If

    Next r

    'trf second sheet row data to range and then to array


    Set rngT = wsT.Range(wsT.Cells(iRW, 2), wsT.Cells(iRW, wsTlc))

    arrT = Application.Transpose(rngT.Value)  'values from range to array


    For r = 1 To UBound(arrT, 1)

    If arrT(r, 1) <> "" Then

    d2(arrT(r, 1)) = 1

    End If

    Next r

    'check values in array agst dict

    'Erase arrN()

    wsR.Cells(iRW, 1).Value = wsT.Cells(iRW, 1).Value

    wsR.Cells(iRW, 2).Value = "Row " & iRW


    For r = 1 To UBound(arrT, 1)

        If Not d.exists(arrT(r, 1)) Then

        'arrN(r, 1) = arrV(r, 1)

        ''wsR.Cells(iRW, r + 1).Value = arrT(r, 1)

        wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrT(r, 1)

        End If

    Next r


    For r = 1 To UBound(arrM, 1)

        If Not d2.exists(arrM(r, 1)) Then

        'arrN(r, 1) = arrV(r, 1)

        ''wsR.Cells(iRW, r + 1).Value = arrM(r, 1)

        wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrM(r, 1)

        End If

    Next r


Next iRW


With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

.AskToUpdateLinks = True

End With

MsgBox "Done"

End Sub

Thanks for reading give feedback and if you want to customise need, post your query on Group www.ExcelVbaLab.Com


Monday, March 14, 2016

Excel VBA Macro to sort sheet having Alpha numeric name

Query: I want to sort sheet in Ascending or Descending order, please not it has Alpha numeric name so I want sort it in serial order e.g. A1,A2,A3,A11,A12 and not A1,A11,A12,A2,A3

Solution: when comes to sorting 1, 11 & 111 are considered as same picture character resulting into sorting sheet incorrectly, try below code to get desired results:

Sub Sort_Active_Book_AlphaNum()

Dim i As Integer

Dim j As Integer

Dim a As Integer, b As Integer, Sn1 As String, Sn2 As String

Dim iAnswer As VbMsgBoxResult

Dim c As String


' Prompt the user as which direction they wish to

' sort the worksheets.


   iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _

     & "Clicking No will sort in Descending Order", _

     vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

   For i = 1 To Sheets.Count

      For j = 1 To Sheets.Count - 1 'Sheets.Count - 1


' If the answer is Yes, then sort in ascending order.


         If iAnswer = vbYes Then

            Sn1 = "": Sn2 = ""

            For a = 1 To Len(Sheets(j).Name)

            If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then

            Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)

            End If

            Next a

            For b = 1 To Len(Sheets(j + 1).Name)

            If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then

            Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)

            End If

            Next b

            If a <> 0 Then

            If Val(Sn1) > Val(Sn2) Then

               Sheets(j).Move After:=Sheets(j + 1)

            End If


            If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then

               Sheets(j).Move After:=Sheets(j + 1)

            End If

            End If


' If the answer is No, then sort in descending order.


         ElseIf iAnswer = vbNo Then


            Sn1 = "": Sn2 = ""

            For a = 1 To Len(Sheets(j).Name)

            If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then

            Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)

            End If

            Next a

            For b = 1 To Len(Sheets(j + 1).Name)

            If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then

            Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)

            End If

            Next b

            If a <> 0 Then

            If Val(Sn1) < Val(Sn2) Then

               Sheets(j).Move After:=Sheets(j + 1)

            End If


            If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then

               Sheets(j).Move After:=Sheets(j + 1)

            End If

            End If



         End If

      Next j

   Next i

End Sub


Friday, March 11, 2016

Macro help required for creating multiple sheet from filtered table & sort alphanumeric sheet name

<data:blog.title/> <data:blog.pageName/>
Query: I have a data in sheet1 & I want to create multiple sheets with name as column A,

Also, I want to repeat header & formats & want to have all sheets name to be sorted alphabetically, please not that sheet name could be alphanumeric so care to be taken accordingly.


Refer attached sheet:



Wednesday, March 9, 2016

Copy visible data from filtered range of all sheets to summary sheet, matching heading

Query: I have sales data in various sheets (about 100 plus columns & a million rows of data in it) also   data is filtered in it. 

I wanted to copy these filtered data to summary sheet, but only a few columns (I have all those columns heading in summary sheet) 

Solution through macro:

Option Explicit 
Sub Macro1() 
    Dim Rng As Range, c As Range 
    Dim sCell As Range 
    Dim rSize As Long 
    Dim dest As Range 
    Dim lDestRow As Long 
    Dim i As Integer 
    Sheets("Base Sheet").Select 
    i = 0 
    Set Rng = Range([D1], [D1].End(xlToRight)) 
    For Each c In Rng 
        Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) 
        rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count 
        If c.Offset(1, 0).Value <> "" Then 
            Set dest = c.End(xlDown).Offset(1, 0) 
            If i = 0 Then 
                lDestRow = dest.Row 
            End If 
            If dest.Row < lDestRow Then 
                Set dest = Cells(lDestRow, dest.Column) 
            End If 
            Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy 
            Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy 
            Set dest = c.Offset(1, 0) 
            If dest.Row < lDestRow Then 
                Set dest = Cells(lDestRow, dest.Column) 
            End If 
        End If 
        i = i + 1 
End Sub

Thursday, March 3, 2016

Print documents from excel through hyperlink assigned to shape or image

Hi, Let's see how you can print pdf or doc file from excel. Nowadays on excel dashboard we seldom give external link to documents through inset image in cells. When we click on an image in a cell we are directed to the document attached to it, and we can view & print that document after it. However, situation would be different when you are asked to print all such hyperlink docs and there are n number of such cells. So lets create a macro to deal with situation, first you need  to set a default printer, then select range containg cells with a image & run below macro

Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _

ByVal hwnd As Long, _

ByVal lpOperation As String, _

ByVal lpFile As String, _

ByVal lpParameters As String, _

ByVal lpDirectory As String, _

ByVal nShowCmd As Long) As Long

Public Function PrintThisDoc(formname As Long, FileName As String)

On Error Resume Next

Dim X As Long

X = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)

End Function

Sub print_hyp_doc()

Dim c As Range, rng As Range

Dim shp As Shape

Dim printThis

Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error Resume Next

For Each c In rng

For Each shp In ActiveSheet.Shapes

If shp.TopLeftCell.Address = c.Address Then

Debug.Print shp.Hyperlink.Address

'shp.Hyperlink.Follow NewWindow:=True

'printThis = PrintThisDoc(0, strDir & "\" & strFile)

printThis = PrintThisDoc(0, shp.Hyperlink.Address)

End If

Next shp


End Sub

Thursday, February 25, 2016

Outlook VBA macro to auto save an incoming email to local folder based on employee code in subject

My HR department receives hundreds of email daily with employee code in subject line they wanted to save all email to local drive having employee code so that any one can access email offline without providing mail access to whole team..

Their requirement was to read subject line of each email & check for employee code and save email so received employee folder in local drive with same subject line. If there is no folder then new folder to be created automatic, all employee code is like VB12345 & all email to save in C:\EmpPersonal\.

Copy and paste below code in outlook in ThisOutlookSession module:

Public WithEvents olItems As Outlook.Items

Private Sub Application_Startup()

    Dim olApp As Outlook.Application

    Dim objNS As Outlook.NameSpace

    Set olApp = Outlook.Application

    Set objNS = olApp.GetNamespace("MAPI")

    Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    On Error GoTo ErrorHandler

    Dim msg As Outlook.MailItem

    Dim endOfSubject As String

    Dim destFolder As String

    Dim myCode As String

    Dim sName As String

    Dim regEx As Object

    Dim matches

    sName = Item.Subject

    ReplaceCharsForFileName sName, "_"

    If TypeName(Item) = "MailItem" Then

        Set msg = Item

         ' check if subject field contains CODE

        Set regEx = CreateObject("VBScript.RegExp")

        With regEx

            .Pattern = "\w+\d{5}"

            .IgnoreCase = True

            .Global = True

        End With

        If regEx.Test(Item.Subject) Then

           Set matches = regEx.Execute(Item.Subject)

           myCode = matches(0)


           Exit Sub

        End If

        destFolder = "C:/EmpPersonal/"

        destFolder = destFolder & myCode

        ' if subfolder doesn't exist, create it

        If Dir(destFolder, vbDirectory) = "" Then

           MkDir destFolder

        End If

        ' Copy msg to local folder

        Item.SaveAs destFolder & "/" & sName & ".msg", olMSG

    End If


    Exit Sub


    MsgBox Err.Number & " - " & Err.Description

    Resume ProgramExit

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _

  sChr As String _


  sName = Replace(sName, "/", sChr)

  sName = Replace(sName, "\", sChr)

  sName = Replace(sName, ":", sChr)

  sName = Replace(sName, "?", sChr)

  sName = Replace(sName, Chr(34), sChr)

  sName = Replace(sName, "<", sChr)

  sName = Replace(sName, ">", sChr)

  sName = Replace(sName, "|", sChr)

End Sub

Do post your feedback on this.....


Monday, January 25, 2016

Excel VBA Macro to Send all selected draft email to sender one by one automatically from Outlook


Many of us have an application to create draft mailers to send it to customers to vendors after reviewing, in case it is few of tens then you can do it manually. How about it is tons or thousands ?

Opening draft email one by one & pressing send button is cumbersome.

Here you go a macro which is designed to work email stored in outlook draft folders. You need to select emails which you want to send & run macro. Macro will loop through emails one by one & sends it to user specified in to filed. If no one is specified to field email will be ignored.

Do let me know if you liked it or not, you can write your queries to


Download File

Saturday, January 23, 2016

Macro of the day : Create dynamic Named Ranges using Macro

Hi All,

Working on dashboards & requires you to create defined name with huge data list, tired of creating names & updating it manually..

Here is simple solution using macro, what you need to do is..

1 - Enter data in main sheet to create defines names of your choice

2 - Macro will create unique names for each item in column B of sheet MainData;
3 - As soon as you type data in sheet MainData, names will get auto updated;
4 - To Delete all names & rebuilt name list click one of the above button;

For any query write back to us on

Give your valuable feedback.


Click to Downloadfile

Thursday, January 21, 2016

Use excel to search image on google and insert link of first image found


Making project where you need to download tens of hundreds of images from web & tired of googling around..Here comes the solution using Excel VBA Macro.

In column A insert name of objects to be download & in Column B you will get URL of Image & in Column C you will get Image of the same size of your cell.

Click to Download

Source Code:
'Requires additional references to Microsoft Internet Control

'Requires additional HTML object library

Public Function URLDecode(url$) As String
    With CreateObject("ScriptControl")
        .Language = "JavaScript"
        URLDecode = .Eval("unescape(""" & url & """)")
    End With
End Function

Public Sub Fetch_Image()

Dim IE As InternetExplorer

Dim HTMLdoc As HTMLDocument

Dim imgElements As IHTMLElementCollection

Dim imgElement As HTMLImg

Dim aElement As HTMLAnchorElement

Dim n As Integer, i As Integer

Dim url As String, url2 As String, furl as string

Dim m, lastRow As Long


lastRow = Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lastRow

    url = "" & Cells(i, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"

    Set IE = New InternetExplorer

    With IE

    .Visible = False

    .navigate url

    Do Until .readyState = 4: DoEvents: Loop

    'Do Until IE.document.readyState = "complete": DoEvents: Loop

    Set HTMLdoc = .document

    Set imgElements = HTMLdoc.getElementsByTagName("IMG")

    n = 1

    For Each imgElement In imgElements

        If InStr(imgElement.src, sImageSearchString) Then

            If imgElement.ParentNode.nodeName = "A" Then

                Set aElement = imgElement.ParentNode


                If n = 2 Then

                url2 = aElement.href

                url3 = imgElement.src

                GoTo done:

                End If

                n = n + 1

                End If

        End If



furl = InStrRev(url2, "&imgrefurl=", -1)

furl = Mid(url2, 40, furl - 40)

furl = URLDecode(furl)

    Cells(i, 2) = furl

    Set m = ActiveSheet.Pictures.Insert(furl)

    With Cells(i, 3)

    t = .Top

    l = .Left

    w = .Width

    h = .Height

    End With

    With m

    .Top = t

    .Left = l

    .ShapeRange.Width = w

    .ShapeRange.Height = h

    End With



Set IE = Nothing

    End With


MsgBox "Done!!"

End Sub